Move most of the DB graph modules to a separate persistent-graph library
This commit is contained in:
fr33domlover
parent
da6d8c008e
commit
250701712a
15 changed files with 7 additions and 2728 deletions
|
|
@ -1,45 +0,0 @@
|
||||||
{- 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.Local.Class.PersistEntityGraph
|
|
||||||
( PersistEntityGraph (..)
|
|
||||||
, PersistEntityGraphSelect (..)
|
|
||||||
, PersistEntityGraphNumbered (..)
|
|
||||||
)
|
|
||||||
where
|
|
||||||
|
|
||||||
import Prelude
|
|
||||||
|
|
||||||
import Data.Proxy (Proxy)
|
|
||||||
import Database.Persist
|
|
||||||
|
|
||||||
class (PersistEntity n, PersistEntity e) => PersistEntityGraph n e where
|
|
||||||
sourceParam :: e -> Key n
|
|
||||||
sourceField :: EntityField e (Key n)
|
|
||||||
destParam :: e -> Key n
|
|
||||||
destField :: EntityField e (Key n)
|
|
||||||
|
|
||||||
class (PersistEntityGraph n e, PersistField (PersistEntityGraphSelector n e))
|
|
||||||
=> PersistEntityGraphSelect n e where
|
|
||||||
type PersistEntityGraphSelector n e
|
|
||||||
selectorParam
|
|
||||||
:: Proxy (n, e) -> n -> PersistEntityGraphSelector n e
|
|
||||||
selectorField
|
|
||||||
:: Proxy (n, e) -> EntityField n (PersistEntityGraphSelector n e)
|
|
||||||
|
|
||||||
class PersistEntityGraphSelect n e => PersistEntityGraphNumbered n e where
|
|
||||||
numberParam :: Proxy (n, e) -> n -> Int
|
|
||||||
numberField :: Proxy (n, e) -> EntityField n Int
|
|
||||||
uniqueNode :: Proxy (n, e) -> PersistEntityGraphSelector n e -> Int -> Unique n
|
|
||||||
|
|
@ -24,7 +24,7 @@ where
|
||||||
import Prelude
|
import Prelude
|
||||||
|
|
||||||
import Database.Persist
|
import Database.Persist
|
||||||
import Database.Persist.Local.Class.PersistEntityGraph
|
import Database.Persist.Graph.Class
|
||||||
|
|
||||||
data HierarchyEdgeDirection n e = TowardsChild | TowardsParent
|
data HierarchyEdgeDirection n e = TowardsChild | TowardsParent
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -1,180 +0,0 @@
|
||||||
{- 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.Local.Class.PersistQueryForest
|
|
||||||
( RecursionDirection (..)
|
|
||||||
, PersistQueryForest (..)
|
|
||||||
, selectForestSource
|
|
||||||
, selectForestKeys
|
|
||||||
, selectForestList
|
|
||||||
, selectForestKeysList
|
|
||||||
)
|
|
||||||
where
|
|
||||||
|
|
||||||
import Prelude
|
|
||||||
|
|
||||||
import Control.Monad.IO.Class
|
|
||||||
import Control.Monad.Reader (MonadReader)
|
|
||||||
import Control.Monad.Trans.Reader (ReaderT)
|
|
||||||
import Control.Monad.Trans.Resource (MonadResource, release)
|
|
||||||
import Data.Acquire (Acquire, allocateAcquire, with)
|
|
||||||
import Database.Persist.Class
|
|
||||||
import Database.Persist.Types
|
|
||||||
|
|
||||||
import qualified Data.Conduit as C
|
|
||||||
import qualified Data.Conduit.List as CL
|
|
||||||
|
|
||||||
data RecursionDirection
|
|
||||||
= Ancestors
|
|
||||||
| Decendants
|
|
||||||
deriving (Eq, Show)
|
|
||||||
|
|
||||||
-- | Backends supporting conditional operations recursively over trees.
|
|
||||||
class PersistQuery backend => PersistQueryForest backend where
|
|
||||||
-- | Update individual fields on any record in the transitive closure and
|
|
||||||
-- matching the given criterion.
|
|
||||||
updateForestWhere
|
|
||||||
:: (MonadIO m, PersistRecordBackend val backend)
|
|
||||||
=> RecursionDirection
|
|
||||||
-> EntityField val (Maybe (Key val))
|
|
||||||
-> Key val
|
|
||||||
-> [Filter val]
|
|
||||||
-> [Update val]
|
|
||||||
-> ReaderT backend m ()
|
|
||||||
|
|
||||||
-- | Delete all records in the transitive closure which match the given
|
|
||||||
-- criterion.
|
|
||||||
deleteForestWhere
|
|
||||||
:: (MonadIO m, PersistRecordBackend val backend)
|
|
||||||
=> RecursionDirection
|
|
||||||
-> EntityField val (Maybe (Key val))
|
|
||||||
-> Key val
|
|
||||||
-> [Filter val]
|
|
||||||
-> ReaderT backend m ()
|
|
||||||
|
|
||||||
-- | Get all records in the transitive closure, which match the given
|
|
||||||
-- criterion, in the specified order. Returns also the identifiers.
|
|
||||||
selectForestSourceRes
|
|
||||||
:: ( PersistRecordBackend val backend
|
|
||||||
, MonadIO m1
|
|
||||||
, MonadIO m2
|
|
||||||
)
|
|
||||||
=> RecursionDirection
|
|
||||||
-> EntityField val (Maybe (Key val))
|
|
||||||
-> Key val
|
|
||||||
-> [Filter val]
|
|
||||||
-> [SelectOpt val]
|
|
||||||
-> ReaderT backend m1 (Acquire (C.Source m2 (Entity val)))
|
|
||||||
|
|
||||||
-- | Get the 'Key's of all records in the transitive closure, which match
|
|
||||||
-- the given criterion.
|
|
||||||
selectForestKeysRes
|
|
||||||
:: ( PersistRecordBackend val backend
|
|
||||||
, MonadIO m1
|
|
||||||
, MonadIO m2
|
|
||||||
)
|
|
||||||
=> RecursionDirection
|
|
||||||
-> EntityField val (Maybe (Key val))
|
|
||||||
-> Key val
|
|
||||||
-> [Filter val]
|
|
||||||
-> [SelectOpt val]
|
|
||||||
-> ReaderT backend m1 (Acquire (C.Source m2 (Key val)))
|
|
||||||
|
|
||||||
-- | The total number of records in the transitive closure which fulfill
|
|
||||||
-- the given criterion.
|
|
||||||
countForest
|
|
||||||
:: (MonadIO m, PersistRecordBackend val backend)
|
|
||||||
=> RecursionDirection
|
|
||||||
-> EntityField val (Maybe (Key val))
|
|
||||||
-> Key val
|
|
||||||
-> [Filter val]
|
|
||||||
-> ReaderT backend m Int
|
|
||||||
|
|
||||||
-- | Get all records in the transitive closure, which match the given
|
|
||||||
-- criterion, in the specified order. Returns also the identifiers.
|
|
||||||
selectForestSource
|
|
||||||
:: ( PersistQueryForest (BaseBackend backend)
|
|
||||||
, MonadResource m
|
|
||||||
, PersistEntity val
|
|
||||||
, PersistEntityBackend val ~ BaseBackend (BaseBackend backend)
|
|
||||||
, MonadReader backend m
|
|
||||||
, HasPersistBackend backend
|
|
||||||
)
|
|
||||||
=> RecursionDirection
|
|
||||||
-> EntityField val (Maybe (Key val))
|
|
||||||
-> Key val
|
|
||||||
-> [Filter val]
|
|
||||||
-> [SelectOpt val]
|
|
||||||
-> C.Source m (Entity val)
|
|
||||||
selectForestSource dir field root filts opts = do
|
|
||||||
srcRes <-
|
|
||||||
liftPersist $ selectForestSourceRes dir field root filts opts
|
|
||||||
(releaseKey, src) <- allocateAcquire srcRes
|
|
||||||
src
|
|
||||||
release releaseKey
|
|
||||||
|
|
||||||
-- | Get the 'Key's of all records in the transitive closure, which match the
|
|
||||||
-- given criterion.
|
|
||||||
selectForestKeys
|
|
||||||
:: ( PersistQueryForest (BaseBackend backend)
|
|
||||||
, MonadResource m
|
|
||||||
, PersistEntity val
|
|
||||||
, BaseBackend (BaseBackend backend) ~ PersistEntityBackend val
|
|
||||||
, MonadReader backend m
|
|
||||||
, HasPersistBackend backend
|
|
||||||
)
|
|
||||||
=> RecursionDirection
|
|
||||||
-> EntityField val (Maybe (Key val))
|
|
||||||
-> Key val
|
|
||||||
-> [Filter val]
|
|
||||||
-> [SelectOpt val]
|
|
||||||
-> C.Source m (Key val)
|
|
||||||
selectForestKeys dir field root filts opts = do
|
|
||||||
srcRes <- liftPersist $ selectForestKeysRes dir field root filts opts
|
|
||||||
(releaseKey, src) <- allocateAcquire srcRes
|
|
||||||
src
|
|
||||||
release releaseKey
|
|
||||||
|
|
||||||
-- | Call 'selectForestSource' but return the result as a list.
|
|
||||||
selectForestList
|
|
||||||
:: ( PersistQueryForest backend
|
|
||||||
, MonadIO m
|
|
||||||
, PersistRecordBackend val backend
|
|
||||||
)
|
|
||||||
=> RecursionDirection
|
|
||||||
-> EntityField val (Maybe (Key val))
|
|
||||||
-> Key val
|
|
||||||
-> [Filter val]
|
|
||||||
-> [SelectOpt val]
|
|
||||||
-> ReaderT backend m [Entity val]
|
|
||||||
selectForestList dir field root filts opts = do
|
|
||||||
srcRes <- selectForestSourceRes dir field root filts opts
|
|
||||||
liftIO $ with srcRes (C.$$ CL.consume)
|
|
||||||
|
|
||||||
-- | Call 'selectForestKeys' but return the result as a list.
|
|
||||||
selectForestKeysList
|
|
||||||
:: ( PersistQueryForest backend
|
|
||||||
, MonadIO m
|
|
||||||
, PersistRecordBackend val backend
|
|
||||||
)
|
|
||||||
=> RecursionDirection
|
|
||||||
-> EntityField val (Maybe (Key val))
|
|
||||||
-> Key val
|
|
||||||
-> [Filter val]
|
|
||||||
-> [SelectOpt val]
|
|
||||||
-> ReaderT backend m [Key val]
|
|
||||||
selectForestKeysList dir field root filts opts = do
|
|
||||||
srcRes <- selectForestKeysRes dir field root filts opts
|
|
||||||
liftIO $ with srcRes (C.$$ CL.consume)
|
|
||||||
|
|
@ -1,279 +0,0 @@
|
||||||
{- 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.Local.Sql
|
|
||||||
( dummyFromField
|
|
||||||
, rawSqlWithGraph
|
|
||||||
, dummyFromFst
|
|
||||||
, dummyFromSnd
|
|
||||||
, destParamFromProxy
|
|
||||||
, sourceParamFromProxy
|
|
||||||
, destFieldFromProxy
|
|
||||||
, sourceFieldFromProxy
|
|
||||||
, (?:)
|
|
||||||
, (?++)
|
|
||||||
, uedge
|
|
||||||
, temp
|
|
||||||
, tid
|
|
||||||
, tpath
|
|
||||||
, tcycle
|
|
||||||
, tcontains
|
|
||||||
, sqlUEdge
|
|
||||||
, FollowDirection (..)
|
|
||||||
, selectGraphNodesList
|
|
||||||
, selectGraphEdgesList
|
|
||||||
)
|
|
||||||
where
|
|
||||||
|
|
||||||
import Prelude
|
|
||||||
|
|
||||||
import Control.Monad.IO.Class (MonadIO, liftIO)
|
|
||||||
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, unpack, intercalate)
|
|
||||||
|
|
||||||
import Database.Persist.Local.Class.PersistEntityGraph
|
|
||||||
import Database.Persist.Local.Class.PersistQueryForest
|
|
||||||
import Database.Persist.Local.Sql.Orphan.Common
|
|
||||||
|
|
||||||
dummyFromKey :: Key val -> Maybe val
|
|
||||||
dummyFromKey _ = Nothing
|
|
||||||
|
|
||||||
dummyFromField :: EntityField val t -> Maybe val
|
|
||||||
dummyFromField _ = Nothing
|
|
||||||
|
|
||||||
dummyFromFst :: Proxy (a, b) -> Maybe a
|
|
||||||
dummyFromFst _ = Nothing
|
|
||||||
|
|
||||||
dummyFromSnd :: Proxy (a, b) -> Maybe b
|
|
||||||
dummyFromSnd _ = Nothing
|
|
||||||
|
|
||||||
destParamFromProxy
|
|
||||||
:: PersistEntityGraph node edge
|
|
||||||
=> Proxy (node, edge)
|
|
||||||
-> edge
|
|
||||||
-> Key node
|
|
||||||
destParamFromProxy _ = destParam
|
|
||||||
|
|
||||||
sourceParamFromProxy
|
|
||||||
:: PersistEntityGraph node edge
|
|
||||||
=> Proxy (node, edge)
|
|
||||||
-> edge
|
|
||||||
-> Key node
|
|
||||||
sourceParamFromProxy _ = sourceParam
|
|
||||||
|
|
||||||
destFieldFromProxy
|
|
||||||
:: PersistEntityGraph node edge
|
|
||||||
=> Proxy (node, edge)
|
|
||||||
-> EntityField edge (Key node)
|
|
||||||
destFieldFromProxy _ = destField
|
|
||||||
|
|
||||||
sourceFieldFromProxy
|
|
||||||
:: PersistEntityGraph node edge
|
|
||||||
=> Proxy (node, edge)
|
|
||||||
-> EntityField edge (Key node)
|
|
||||||
sourceFieldFromProxy _ = sourceField
|
|
||||||
|
|
||||||
data FollowDirection = FollowForward | FollowBackward | FollowBoth
|
|
||||||
deriving (Eq, Show)
|
|
||||||
|
|
||||||
rawSqlWithGraph
|
|
||||||
:: ( RawSql a
|
|
||||||
, MonadIO m
|
|
||||||
, PersistEntity node
|
|
||||||
, PersistEntity edge
|
|
||||||
, SqlBackend ~ PersistEntityBackend node
|
|
||||||
, SqlBackend ~ PersistEntityBackend edge
|
|
||||||
)
|
|
||||||
=> RecursionDirection
|
|
||||||
-> Key node
|
|
||||||
-> EntityField edge (Key node)
|
|
||||||
-> EntityField edge (Key node)
|
|
||||||
-> (DBName -> Text)
|
|
||||||
-> [PersistValue]
|
|
||||||
-> ReaderT SqlBackend m [a]
|
|
||||||
rawSqlWithGraph dir root parent child sub vals = do
|
|
||||||
conn <- ask
|
|
||||||
let tNode = entityDef $ dummyFromKey root
|
|
||||||
tEdge = entityDef $ dummyFromField parent
|
|
||||||
temp = DBName "temp_hierarchy_cte"
|
|
||||||
dbname = connEscapeName conn
|
|
||||||
immediate =
|
|
||||||
case dir of
|
|
||||||
Ancestors -> child ==. root
|
|
||||||
Decendants -> parent ==. root
|
|
||||||
cols = T.intercalate "," $ entityColumnNames tEdge conn
|
|
||||||
qcols name =
|
|
||||||
T.intercalate ", " $
|
|
||||||
map ((dbname name <>) . ("." <>)) $
|
|
||||||
entityColumnNames tEdge conn
|
|
||||||
sqlWith = mconcat
|
|
||||||
[ "WITH RECURSIVE "
|
|
||||||
, dbname temp
|
|
||||||
, " ("
|
|
||||||
, cols
|
|
||||||
, ") AS ( SELECT "
|
|
||||||
, cols
|
|
||||||
, " FROM "
|
|
||||||
, dbname $ entityDB tEdge
|
|
||||||
, filterClause False conn [immediate]
|
|
||||||
, " UNION SELECT "
|
|
||||||
, qcols $ entityDB tEdge
|
|
||||||
, " FROM "
|
|
||||||
, dbname $ entityDB tEdge
|
|
||||||
, ", "
|
|
||||||
, dbname temp
|
|
||||||
, " WHERE "
|
|
||||||
, dbname $ entityDB tEdge
|
|
||||||
, "."
|
|
||||||
, dbname $ fieldDB $ persistFieldDef $ case dir of
|
|
||||||
Ancestors -> child
|
|
||||||
Decendants -> parent
|
|
||||||
, " = "
|
|
||||||
, dbname temp
|
|
||||||
, "."
|
|
||||||
, dbname $ fieldDB $ persistFieldDef $ case dir of
|
|
||||||
Ancestors -> parent
|
|
||||||
Decendants -> child
|
|
||||||
, " ) "
|
|
||||||
]
|
|
||||||
sql = sqlWith <> sub temp
|
|
||||||
vals' = toPersistValue root : vals
|
|
||||||
rawSql sql vals'
|
|
||||||
|
|
||||||
(?:) :: Maybe a -> [a] -> [a]
|
|
||||||
(?:) = maybe id (:)
|
|
||||||
infixr 5 ?:
|
|
||||||
|
|
||||||
(?++) :: Maybe [a] -> [a] -> [a]
|
|
||||||
(?++) = maybe id (++)
|
|
||||||
infixr 5 ?++
|
|
||||||
|
|
||||||
uedge :: DBName
|
|
||||||
uedge = DBName "temp_undirected_edge_cte"
|
|
||||||
|
|
||||||
ubase :: DBName
|
|
||||||
ubase = DBName "temp_undirected_base_cte"
|
|
||||||
|
|
||||||
temp :: DBName
|
|
||||||
temp = DBName "temp_hierarchy_cte"
|
|
||||||
|
|
||||||
tid :: DBName
|
|
||||||
tid = DBName "id"
|
|
||||||
|
|
||||||
tpath :: DBName
|
|
||||||
tpath = DBName "path"
|
|
||||||
|
|
||||||
tcycle :: DBName
|
|
||||||
tcycle = DBName "cycle"
|
|
||||||
|
|
||||||
tcontains :: DBName
|
|
||||||
tcontains = DBName "contains"
|
|
||||||
|
|
||||||
sqlUEdge
|
|
||||||
:: (DBName -> Text) -> Text -> EntityDef -> FieldDef -> FieldDef -> Text
|
|
||||||
sqlUEdge dbname filt tEdge bwd fwd =
|
|
||||||
let t ^* f = dbname t <> "." <> dbname f
|
|
||||||
sqlBase = mconcat
|
|
||||||
[ dbname ubase
|
|
||||||
, " ("
|
|
||||||
, dbname $ fieldDB bwd, ", ", dbname $ fieldDB fwd
|
|
||||||
, ") AS (SELECT "
|
|
||||||
, entityDB tEdge ^* fieldDB bwd
|
|
||||||
, ", "
|
|
||||||
, entityDB tEdge ^* fieldDB fwd
|
|
||||||
, " FROM ", dbname $ entityDB tEdge
|
|
||||||
, filt
|
|
||||||
, "), "
|
|
||||||
]
|
|
||||||
sqlEdge base = mconcat
|
|
||||||
[ dbname uedge
|
|
||||||
, " ("
|
|
||||||
, dbname $ fieldDB bwd, ", ", dbname $ fieldDB fwd
|
|
||||||
, ") AS (SELECT "
|
|
||||||
, base ^* fieldDB bwd, ", ", base ^* fieldDB fwd
|
|
||||||
, " FROM ", dbname base
|
|
||||||
, " UNION ALL SELECT "
|
|
||||||
, base ^* fieldDB fwd, ", ", base ^* fieldDB bwd
|
|
||||||
, " FROM ", dbname base
|
|
||||||
, ")"
|
|
||||||
]
|
|
||||||
in if T.null filt
|
|
||||||
then sqlEdge $ entityDB tEdge
|
|
||||||
else sqlBase <> sqlEdge ubase
|
|
||||||
|
|
||||||
selectGraphNodesList
|
|
||||||
:: ( MonadIO m
|
|
||||||
, PersistEntityGraphSelect node edge
|
|
||||||
, BaseBackend backend ~ PersistEntityBackend node
|
|
||||||
, BaseBackend backend ~ PersistEntityBackend edge
|
|
||||||
, PersistQueryRead backend
|
|
||||||
)
|
|
||||||
=> PersistEntityGraphSelector node edge
|
|
||||||
-> [Filter node]
|
|
||||||
-> [SelectOpt node]
|
|
||||||
-> Proxy (node, edge)
|
|
||||||
-> ReaderT backend m [Entity node]
|
|
||||||
selectGraphNodesList sel filt opts proxy =
|
|
||||||
selectList ((selectorField proxy ==. sel) : filt) opts
|
|
||||||
|
|
||||||
selectGraphEdgesList
|
|
||||||
:: ( MonadIO m
|
|
||||||
, PersistEntityGraphSelect node edge
|
|
||||||
, SqlBackend ~ PersistEntityBackend node
|
|
||||||
, SqlBackend ~ PersistEntityBackend edge
|
|
||||||
)
|
|
||||||
=> PersistEntityGraphSelector node edge
|
|
||||||
-> [Filter edge]
|
|
||||||
-> [SelectOpt edge]
|
|
||||||
-> Proxy (node, edge)
|
|
||||||
-> ReaderT SqlBackend m [Entity edge]
|
|
||||||
selectGraphEdgesList sel filt opts proxy = do
|
|
||||||
conn <- ask
|
|
||||||
let tNode = entityDef $ dummyFromFst proxy
|
|
||||||
tEdge = entityDef $ dummyFromSnd proxy
|
|
||||||
dbname = connEscapeName conn
|
|
||||||
t ^* f = dbname t <> "." <> dbname f
|
|
||||||
t <#> f = dbname t <> " INNER JOIN " <> dbname f
|
|
||||||
(limit, offset, orders) = limitOffsetOrder opts
|
|
||||||
applyLimitOffset =
|
|
||||||
connLimitOffset conn (limit, offset) (not $ null orders)
|
|
||||||
sql = applyLimitOffset $ mconcat
|
|
||||||
[ "SELECT ?? FROM ", entityDB tNode <#> entityDB tEdge, " ON "
|
|
||||||
, entityDB tNode ^* (fieldDB $ entityId tNode)
|
|
||||||
, " = "
|
|
||||||
, entityDB tEdge ^*
|
|
||||||
(fieldDB $ persistFieldDef $ sourceFieldFromProxy proxy)
|
|
||||||
, let flt = filterClause True conn filt
|
|
||||||
in if T.null flt
|
|
||||||
then " WHERE"
|
|
||||||
else flt
|
|
||||||
, " AND "
|
|
||||||
, entityDB tNode ^*
|
|
||||||
(fieldDB $ persistFieldDef $ selectorField proxy)
|
|
||||||
, " = ? "
|
|
||||||
, case map (orderClause True conn) orders of
|
|
||||||
[] -> ""
|
|
||||||
ords -> " ORDER BY " <> T.intercalate ", " ords
|
|
||||||
]
|
|
||||||
vals = getFiltsValues conn filt ++ [toPersistValue sel]
|
|
||||||
rawSql sql vals
|
|
||||||
|
|
@ -1,234 +0,0 @@
|
||||||
{- This file contains (slightly modified) copies of unexported functions from
|
|
||||||
- Database.Persist.Sql.Orphan.PersistQuery, which I need for my
|
|
||||||
- PersistQueryRecursive implementation. They're released under MIT.
|
|
||||||
-
|
|
||||||
- This should be a temporary situation. Either my code moves to persistent and
|
|
||||||
- the functions are reused there, or these functions become exported in
|
|
||||||
- persistent and then I can import them instead of holding copies.
|
|
||||||
-}
|
|
||||||
|
|
||||||
{-# LANGUAGE RankNTypes #-}
|
|
||||||
|
|
||||||
module Database.Persist.Local.Sql.Orphan.Common
|
|
||||||
( fieldName
|
|
||||||
, dummyFromFilts
|
|
||||||
, getFiltsValues
|
|
||||||
, filterClause
|
|
||||||
, orderClause
|
|
||||||
)
|
|
||||||
where
|
|
||||||
|
|
||||||
import Prelude
|
|
||||||
|
|
||||||
import Data.List (inits, transpose)
|
|
||||||
import Data.Monoid ((<>))
|
|
||||||
import Data.Text (Text)
|
|
||||||
import Database.Persist
|
|
||||||
import Database.Persist.Sql
|
|
||||||
import Database.Persist.Sql.Util
|
|
||||||
|
|
||||||
import qualified Data.Text as T
|
|
||||||
|
|
||||||
fieldName
|
|
||||||
:: forall record typ.
|
|
||||||
(PersistEntity record , PersistEntityBackend record ~ SqlBackend)
|
|
||||||
=> EntityField record typ
|
|
||||||
-> DBName
|
|
||||||
fieldName f = fieldDB $ persistFieldDef f
|
|
||||||
|
|
||||||
dummyFromFilts :: [Filter v] -> Maybe v
|
|
||||||
dummyFromFilts _ = Nothing
|
|
||||||
|
|
||||||
getFiltsValues
|
|
||||||
:: forall val. (PersistEntity val, PersistEntityBackend val ~ SqlBackend)
|
|
||||||
=> SqlBackend
|
|
||||||
-> [Filter val]
|
|
||||||
-> [PersistValue]
|
|
||||||
getFiltsValues conn = snd . filterClauseHelper False False conn OrNullNo
|
|
||||||
|
|
||||||
data OrNull = OrNullYes | OrNullNo
|
|
||||||
|
|
||||||
filterClauseHelper
|
|
||||||
:: (PersistEntity val, PersistEntityBackend val ~ SqlBackend)
|
|
||||||
=> Bool -- ^ include table name?
|
|
||||||
-> Bool -- ^ include WHERE?
|
|
||||||
-> SqlBackend
|
|
||||||
-> OrNull
|
|
||||||
-> [Filter val]
|
|
||||||
-> (Text, [PersistValue])
|
|
||||||
filterClauseHelper includeTable includeWhere conn orNull filters =
|
|
||||||
( if not (T.null sql) && includeWhere
|
|
||||||
then " WHERE " <> sql
|
|
||||||
else sql
|
|
||||||
, vals
|
|
||||||
)
|
|
||||||
where
|
|
||||||
(sql, vals) = combineAND filters
|
|
||||||
combineAND = combine " AND "
|
|
||||||
|
|
||||||
combine s fs =
|
|
||||||
(T.intercalate s $ map wrapP a, mconcat b)
|
|
||||||
where
|
|
||||||
(a, b) = unzip $ map go fs
|
|
||||||
wrapP x = T.concat ["(", x, ")"]
|
|
||||||
|
|
||||||
go (BackendFilter _) = error "BackendFilter not expected"
|
|
||||||
go (FilterAnd []) = ("1=1", [])
|
|
||||||
go (FilterAnd fs) = combineAND fs
|
|
||||||
go (FilterOr []) = ("1=0", [])
|
|
||||||
go (FilterOr fs) = combine " OR " fs
|
|
||||||
go (Filter field value pfilter) =
|
|
||||||
let t = entityDef $ dummyFromFilts [Filter field value pfilter]
|
|
||||||
in case (isIdField field, entityPrimary t, allVals) of
|
|
||||||
(True, Just pdef, PersistList ys:_) ->
|
|
||||||
if length (compositeFields pdef) /= length ys
|
|
||||||
then error $ "wrong number of entries in compositeFields vs PersistList allVals=" ++ show allVals
|
|
||||||
else
|
|
||||||
case (allVals, pfilter, isCompFilter pfilter) of
|
|
||||||
([PersistList xs], Eq, _) ->
|
|
||||||
let sqlcl=T.intercalate " and " (map (\a -> connEscapeName conn (fieldDB a) <> showSqlFilter pfilter <> "? ") (compositeFields pdef))
|
|
||||||
in (wrapSql sqlcl,xs)
|
|
||||||
([PersistList xs], Ne, _) ->
|
|
||||||
let sqlcl=T.intercalate " or " (map (\a -> connEscapeName conn (fieldDB a) <> showSqlFilter pfilter <> "? ") (compositeFields pdef))
|
|
||||||
in (wrapSql sqlcl,xs)
|
|
||||||
(_, In, _) ->
|
|
||||||
let xxs = transpose (map fromPersistList allVals)
|
|
||||||
sqls=map (\(a,xs) -> connEscapeName conn (fieldDB a) <> showSqlFilter pfilter <> "(" <> T.intercalate "," (replicate (length xs) " ?") <> ") ") (zip (compositeFields pdef) xxs)
|
|
||||||
in (wrapSql (T.intercalate " and " (map wrapSql sqls)), concat xxs)
|
|
||||||
(_, NotIn, _) ->
|
|
||||||
let xxs = transpose (map fromPersistList allVals)
|
|
||||||
sqls=map (\(a,xs) -> connEscapeName conn (fieldDB a) <> showSqlFilter pfilter <> "(" <> T.intercalate "," (replicate (length xs) " ?") <> ") ") (zip (compositeFields pdef) xxs)
|
|
||||||
in (wrapSql (T.intercalate " or " (map wrapSql sqls)), concat xxs)
|
|
||||||
([PersistList xs], _, True) ->
|
|
||||||
let zs = tail (inits (compositeFields pdef))
|
|
||||||
sql1 = map (\b -> wrapSql (T.intercalate " and " (map (\(i,a) -> sql2 (i==length b) a) (zip [1..] b)))) zs
|
|
||||||
sql2 islast a = connEscapeName conn (fieldDB a) <> (if islast then showSqlFilter pfilter else showSqlFilter Eq) <> "? "
|
|
||||||
sqlcl = T.intercalate " or " sql1
|
|
||||||
in (wrapSql sqlcl, concat (tail (inits xs)))
|
|
||||||
(_, BackendSpecificFilter _, _) -> error "unhandled type BackendSpecificFilter for composite/non id primary keys"
|
|
||||||
_ -> error $ "unhandled type/filter for composite/non id primary keys pfilter=" ++ show pfilter ++ " persistList="++show allVals
|
|
||||||
(True, Just pdef, _) -> error $ "unhandled error for composite/non id primary keys pfilter=" ++ show pfilter ++ " persistList=" ++ show allVals ++ " pdef=" ++ show pdef
|
|
||||||
|
|
||||||
_ -> case (isNull, pfilter, varCount) of
|
|
||||||
(True, Eq, _) -> (name <> " IS NULL", [])
|
|
||||||
(True, Ne, _) -> (name <> " IS NOT NULL", [])
|
|
||||||
(False, Ne, _) -> (T.concat
|
|
||||||
[ "("
|
|
||||||
, name
|
|
||||||
, " IS NULL OR "
|
|
||||||
, name
|
|
||||||
, " <> "
|
|
||||||
, qmarks
|
|
||||||
, ")"
|
|
||||||
], notNullVals)
|
|
||||||
-- We use 1=2 (and below 1=1) to avoid using TRUE and FALSE, since
|
|
||||||
-- not all databases support those words directly.
|
|
||||||
(_, In, 0) -> ("1=2" <> orNullSuffix, [])
|
|
||||||
(False, In, _) -> (name <> " IN " <> qmarks <> orNullSuffix, allVals)
|
|
||||||
(True, In, _) -> (T.concat
|
|
||||||
[ "("
|
|
||||||
, name
|
|
||||||
, " IS NULL OR "
|
|
||||||
, name
|
|
||||||
, " IN "
|
|
||||||
, qmarks
|
|
||||||
, ")"
|
|
||||||
], notNullVals)
|
|
||||||
(_, NotIn, 0) -> ("1=1", [])
|
|
||||||
(False, NotIn, _) -> (T.concat
|
|
||||||
[ "("
|
|
||||||
, name
|
|
||||||
, " IS NULL OR "
|
|
||||||
, name
|
|
||||||
, " NOT IN "
|
|
||||||
, qmarks
|
|
||||||
, ")"
|
|
||||||
], notNullVals)
|
|
||||||
(True, NotIn, _) -> (T.concat
|
|
||||||
[ "("
|
|
||||||
, name
|
|
||||||
, " IS NOT NULL AND "
|
|
||||||
, name
|
|
||||||
, " NOT IN "
|
|
||||||
, qmarks
|
|
||||||
, ")"
|
|
||||||
], notNullVals)
|
|
||||||
_ -> (name <> showSqlFilter pfilter <> "?" <> orNullSuffix, allVals)
|
|
||||||
|
|
||||||
where
|
|
||||||
isCompFilter Lt = True
|
|
||||||
isCompFilter Le = True
|
|
||||||
isCompFilter Gt = True
|
|
||||||
isCompFilter Ge = True
|
|
||||||
isCompFilter _ = False
|
|
||||||
|
|
||||||
wrapSql sqlcl = "(" <> sqlcl <> ")"
|
|
||||||
fromPersistList (PersistList xs) = xs
|
|
||||||
fromPersistList other = error $ "expected PersistList but found " ++ show other
|
|
||||||
|
|
||||||
filterValueToPersistValues :: forall a. PersistField a => Either a [a] -> [PersistValue]
|
|
||||||
filterValueToPersistValues v = map toPersistValue $ either return id v
|
|
||||||
|
|
||||||
orNullSuffix =
|
|
||||||
case orNull of
|
|
||||||
OrNullYes -> mconcat [" OR ", name, " IS NULL"]
|
|
||||||
OrNullNo -> ""
|
|
||||||
|
|
||||||
isNull = any (== PersistNull) allVals
|
|
||||||
notNullVals = filter (/= PersistNull) allVals
|
|
||||||
allVals = filterValueToPersistValues value
|
|
||||||
tn = connEscapeName conn $ entityDB
|
|
||||||
$ entityDef $ dummyFromFilts [Filter field value pfilter]
|
|
||||||
name =
|
|
||||||
(if includeTable
|
|
||||||
then ((tn <> ".") <>)
|
|
||||||
else id)
|
|
||||||
$ connEscapeName conn $ fieldName field
|
|
||||||
qmarks = case value of
|
|
||||||
Left _ -> "?"
|
|
||||||
Right x ->
|
|
||||||
let x' = filter (/= PersistNull) $ map toPersistValue x
|
|
||||||
in "(" <> T.intercalate "," (map (const "?") x') <> ")"
|
|
||||||
varCount = case value of
|
|
||||||
Left _ -> 1
|
|
||||||
Right x -> length x
|
|
||||||
showSqlFilter Eq = "="
|
|
||||||
showSqlFilter Ne = "<>"
|
|
||||||
showSqlFilter Gt = ">"
|
|
||||||
showSqlFilter Lt = "<"
|
|
||||||
showSqlFilter Ge = ">="
|
|
||||||
showSqlFilter Le = "<="
|
|
||||||
showSqlFilter In = " IN "
|
|
||||||
showSqlFilter NotIn = " NOT IN "
|
|
||||||
showSqlFilter (BackendSpecificFilter s) = s
|
|
||||||
|
|
||||||
filterClause :: (PersistEntity val, PersistEntityBackend val ~ SqlBackend)
|
|
||||||
=> Bool -- ^ include table name?
|
|
||||||
-> SqlBackend
|
|
||||||
-> [Filter val]
|
|
||||||
-> Text
|
|
||||||
filterClause b c = fst . filterClauseHelper b True c OrNullNo
|
|
||||||
|
|
||||||
orderClause :: (PersistEntity val, PersistEntityBackend val ~ SqlBackend)
|
|
||||||
=> Bool -- ^ include the table name
|
|
||||||
-> SqlBackend
|
|
||||||
-> SelectOpt val
|
|
||||||
-> Text
|
|
||||||
orderClause includeTable conn o =
|
|
||||||
case o of
|
|
||||||
Asc x -> name x
|
|
||||||
Desc x -> name x <> " DESC"
|
|
||||||
_ -> error "orderClause: expected Asc or Desc, not limit or offset"
|
|
||||||
where
|
|
||||||
dummyFromOrder :: SelectOpt a -> Maybe a
|
|
||||||
dummyFromOrder _ = Nothing
|
|
||||||
|
|
||||||
tn = connEscapeName conn $ entityDB $ entityDef $ dummyFromOrder o
|
|
||||||
|
|
||||||
name :: (PersistEntityBackend record ~ SqlBackend, PersistEntity record)
|
|
||||||
=> EntityField record typ -> Text
|
|
||||||
name x =
|
|
||||||
(if includeTable
|
|
||||||
then ((tn <> ".") <>)
|
|
||||||
else id)
|
|
||||||
$ connEscapeName conn $ fieldName x
|
|
||||||
|
|
@ -1,333 +0,0 @@
|
||||||
{- 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.Local.Sql.Orphan.PersistQueryForest
|
|
||||||
( deleteForestWhereCount
|
|
||||||
, updateForestWhereCount
|
|
||||||
)
|
|
||||||
where
|
|
||||||
|
|
||||||
import Prelude
|
|
||||||
|
|
||||||
import Control.Monad (void)
|
|
||||||
import Control.Monad.IO.Class
|
|
||||||
import Control.Monad.Trans.Reader (ReaderT, ask)
|
|
||||||
import Control.Exception (throwIO)
|
|
||||||
import Data.ByteString.Char8 (readInteger)
|
|
||||||
import Data.Conduit (($=))
|
|
||||||
import Data.Foldable (find)
|
|
||||||
import Data.Int (Int64)
|
|
||||||
import Data.Maybe (isJust)
|
|
||||||
import Data.Monoid ((<>))
|
|
||||||
import Data.Text (Text)
|
|
||||||
import Database.Persist
|
|
||||||
import Database.Persist.Sql
|
|
||||||
import Database.Persist.Sql.Util
|
|
||||||
|
|
||||||
import qualified Data.Conduit.List as CL (head, mapM)
|
|
||||||
import qualified Data.Text as T (pack, unpack, intercalate)
|
|
||||||
|
|
||||||
import Database.Persist.Local.Class.PersistQueryForest
|
|
||||||
import Database.Persist.Local.Sql.Orphan.Common
|
|
||||||
|
|
||||||
instance PersistQueryForest SqlBackend where
|
|
||||||
updateForestWhere dir field root filts upds =
|
|
||||||
void $ updateForestWhereCount dir field root filts upds
|
|
||||||
|
|
||||||
deleteForestWhere dir field root filts =
|
|
||||||
void $ deleteForestWhereCount dir field root filts
|
|
||||||
|
|
||||||
selectForestSourceRes dir field root filts opts = do
|
|
||||||
conn <- ask
|
|
||||||
let (sql, vals, parse) = sqlValsParse conn
|
|
||||||
srcRes <- rawQueryRes sql vals
|
|
||||||
return $ fmap ($= CL.mapM parse) srcRes
|
|
||||||
where
|
|
||||||
sqlValsParse conn = (sql, vals, parse)
|
|
||||||
where
|
|
||||||
(temp, isRoot, cols, qcols, sqlWith) =
|
|
||||||
withRecursive dir field root conn t (flip entityColumnNames)
|
|
||||||
|
|
||||||
(limit, offset, orders) = limitOffsetOrder opts
|
|
||||||
|
|
||||||
parse xs =
|
|
||||||
case parseEntityValues t xs of
|
|
||||||
Left s -> liftIO $ throwIO $ PersistMarshalError s
|
|
||||||
Right row -> return row
|
|
||||||
t = entityDef $ dummyFromFilts filts
|
|
||||||
wher =
|
|
||||||
if null filts
|
|
||||||
then ""
|
|
||||||
else filterClause False conn filts
|
|
||||||
ord =
|
|
||||||
case map (orderClause False conn) orders of
|
|
||||||
[] -> ""
|
|
||||||
ords -> " ORDER BY " <> T.intercalate "," ords
|
|
||||||
sql =
|
|
||||||
mappend sqlWith $
|
|
||||||
connLimitOffset conn (limit, offset) (not $ null orders) $
|
|
||||||
mconcat
|
|
||||||
[ "SELECT "
|
|
||||||
, cols
|
|
||||||
, " FROM "
|
|
||||||
, connEscapeName conn temp
|
|
||||||
, wher
|
|
||||||
, ord
|
|
||||||
]
|
|
||||||
vals = getFiltsValues conn $ isRoot : filts
|
|
||||||
|
|
||||||
selectForestKeysRes dir field root filts opts = do
|
|
||||||
conn <- ask
|
|
||||||
let (sql, vals, parse) = sqlValsParse conn
|
|
||||||
srcRes <- rawQueryRes sql vals
|
|
||||||
return $ fmap ($= CL.mapM parse) srcRes
|
|
||||||
where
|
|
||||||
sqlValsParse conn = (sql, vals, parse)
|
|
||||||
where
|
|
||||||
(temp, isRoot, cols, qcols, sqlWith) =
|
|
||||||
withRecursive dir field root conn t dbIdColumns
|
|
||||||
|
|
||||||
(limit, offset, orders) = limitOffsetOrder opts
|
|
||||||
|
|
||||||
parse xs = do
|
|
||||||
keyvals <-
|
|
||||||
case entityPrimary t of
|
|
||||||
Nothing ->
|
|
||||||
case xs of
|
|
||||||
[PersistInt64 x] ->
|
|
||||||
return [PersistInt64 x]
|
|
||||||
[PersistDouble x] ->
|
|
||||||
-- oracle returns Double
|
|
||||||
return [PersistInt64 $ truncate x]
|
|
||||||
_ ->
|
|
||||||
liftIO $ throwIO $ PersistMarshalError $
|
|
||||||
"Unexpected in selectKeys False: " <>
|
|
||||||
T.pack (show xs)
|
|
||||||
Just pdef ->
|
|
||||||
let pks = map fieldHaskell $ compositeFields pdef
|
|
||||||
keyvals =
|
|
||||||
map snd $
|
|
||||||
filter
|
|
||||||
(\ (a, _) ->
|
|
||||||
let ret = isJust (find (== a) pks)
|
|
||||||
in ret
|
|
||||||
) $
|
|
||||||
zip (map fieldHaskell $ entityFields t) xs
|
|
||||||
in return keyvals
|
|
||||||
case keyFromValues keyvals of
|
|
||||||
Right k -> return k
|
|
||||||
Left _ -> error "selectKeysImpl: keyFromValues failed"
|
|
||||||
t = entityDef $ dummyFromFilts filts
|
|
||||||
wher =
|
|
||||||
if null filts
|
|
||||||
then ""
|
|
||||||
else filterClause False conn filts
|
|
||||||
ord =
|
|
||||||
case map (orderClause False conn) orders of
|
|
||||||
[] -> ""
|
|
||||||
ords -> " ORDER BY " <> T.intercalate "," ords
|
|
||||||
sql =
|
|
||||||
mappend sqlWith $
|
|
||||||
connLimitOffset conn (limit, offset) (not $ null orders) $
|
|
||||||
mconcat
|
|
||||||
[ "SELECT "
|
|
||||||
, cols
|
|
||||||
, " FROM "
|
|
||||||
, connEscapeName conn temp
|
|
||||||
, wher
|
|
||||||
, ord
|
|
||||||
]
|
|
||||||
vals = getFiltsValues conn $ isRoot : filts
|
|
||||||
|
|
||||||
countForest dir field root filts = do
|
|
||||||
conn <- ask
|
|
||||||
let (sql, vals) = sqlAndVals conn
|
|
||||||
withRawQuery sql vals $ do
|
|
||||||
mm <- CL.head
|
|
||||||
case mm of
|
|
||||||
Just [PersistInt64 i] -> return $ fromIntegral i
|
|
||||||
Just [PersistDouble i] ->return $ fromIntegral (truncate i :: Int64) -- gb oracle
|
|
||||||
Just [PersistByteString i] -> case readInteger i of -- gb mssql
|
|
||||||
Just (ret,"") -> return $ fromIntegral ret
|
|
||||||
xs -> error $ "invalid number i["++show i++"] xs[" ++ show xs ++ "]"
|
|
||||||
Just xs -> error $ "count:invalid sql return xs["++show xs++"] sql["++show sql++"]"
|
|
||||||
Nothing -> error $ "count:invalid sql returned nothing sql["++show sql++"]"
|
|
||||||
where
|
|
||||||
sqlAndVals conn = (sql, vals)
|
|
||||||
where
|
|
||||||
(temp, isRoot, cols, qcols, sqlWith) =
|
|
||||||
withRecursive dir field root conn t dbIdColumns
|
|
||||||
|
|
||||||
t = entityDef $ dummyFromFilts filts
|
|
||||||
wher =
|
|
||||||
if null filts
|
|
||||||
then ""
|
|
||||||
else filterClause False conn filts
|
|
||||||
sql = mconcat
|
|
||||||
[ sqlWith
|
|
||||||
, "SELECT COUNT(*) FROM "
|
|
||||||
, connEscapeName conn temp
|
|
||||||
, wher
|
|
||||||
]
|
|
||||||
vals = getFiltsValues conn $ isRoot : filts
|
|
||||||
|
|
||||||
-- | Same as 'deleteForestWhere', but returns the number of rows affected.
|
|
||||||
deleteForestWhereCount
|
|
||||||
:: (PersistEntity val, MonadIO m, PersistEntityBackend val ~ SqlBackend)
|
|
||||||
=> RecursionDirection
|
|
||||||
-> EntityField val (Maybe (Key val))
|
|
||||||
-> Key val
|
|
||||||
-> [Filter val]
|
|
||||||
-> ReaderT SqlBackend m Int64
|
|
||||||
deleteForestWhereCount dir field root filts = do
|
|
||||||
conn <- ask
|
|
||||||
let (sql, vals) = sqlAndVals conn
|
|
||||||
rawExecuteCount sql vals
|
|
||||||
where
|
|
||||||
sqlAndVals conn = (sql, vals)
|
|
||||||
where
|
|
||||||
(temp, isRoot, cols, qcols, sqlWith) =
|
|
||||||
withRecursive dir field root conn t dbIdColumns
|
|
||||||
|
|
||||||
t = entityDef $ dummyFromFilts filts
|
|
||||||
wher = mconcat
|
|
||||||
[ if null filts
|
|
||||||
then " WHERE ( "
|
|
||||||
else filterClause False conn filts <> " AND ( "
|
|
||||||
, connEscapeName conn $ fieldDB $ entityId t
|
|
||||||
, " IN (SELECT "
|
|
||||||
, connEscapeName conn $ fieldDB $ entityId t
|
|
||||||
, " FROM "
|
|
||||||
, connEscapeName conn temp
|
|
||||||
, ") ) "
|
|
||||||
]
|
|
||||||
sql = mconcat
|
|
||||||
[ sqlWith
|
|
||||||
, "DELETE FROM "
|
|
||||||
, connEscapeName conn $ entityDB t
|
|
||||||
, wher
|
|
||||||
]
|
|
||||||
vals = getFiltsValues conn $ isRoot : filts
|
|
||||||
|
|
||||||
-- | Same as 'updateForestWhere', but returns the number of rows affected.
|
|
||||||
updateForestWhereCount
|
|
||||||
:: (PersistEntity val, MonadIO m, SqlBackend ~ PersistEntityBackend val)
|
|
||||||
=> RecursionDirection
|
|
||||||
-> EntityField val (Maybe (Key val))
|
|
||||||
-> Key val
|
|
||||||
-> [Filter val]
|
|
||||||
-> [Update val]
|
|
||||||
-> ReaderT SqlBackend m Int64
|
|
||||||
updateForestWhereCount _ _ _ _ [] = return 0
|
|
||||||
updateForestWhereCount dir field root filts upds = do
|
|
||||||
conn <- ask
|
|
||||||
let (sql, vals) = sqlAndVals conn
|
|
||||||
rawExecuteCount sql vals
|
|
||||||
where
|
|
||||||
sqlAndVals conn = (sql, vals)
|
|
||||||
where
|
|
||||||
(temp, isRoot, cols, qcols, sqlWith) =
|
|
||||||
withRecursive dir field root conn t dbIdColumns
|
|
||||||
|
|
||||||
t = entityDef $ dummyFromFilts filts
|
|
||||||
|
|
||||||
go'' n Assign = n <> "=?"
|
|
||||||
go'' n Add = mconcat [n, "=", n, "+?"]
|
|
||||||
go'' n Subtract = mconcat [n, "=", n, "-?"]
|
|
||||||
go'' n Multiply = mconcat [n, "=", n, "*?"]
|
|
||||||
go'' n Divide = mconcat [n, "=", n, "/?"]
|
|
||||||
go'' _ (BackendSpecificUpdate up) =
|
|
||||||
error $ T.unpack $ "BackendSpecificUpdate " <> up <> " not supported"
|
|
||||||
go' (x, pu) = go'' (connEscapeName conn x) pu
|
|
||||||
go x = (updateField x, updateUpdate x)
|
|
||||||
|
|
||||||
updateField (Update f _ _) = fieldName f
|
|
||||||
updateField _ = error "BackendUpdate not implemented"
|
|
||||||
|
|
||||||
wher = mconcat
|
|
||||||
[ if null filts
|
|
||||||
then " WHERE ( "
|
|
||||||
else filterClause False conn filts <> " AND ( "
|
|
||||||
, connEscapeName conn $ fieldDB $ entityId t
|
|
||||||
, " IN (SELECT "
|
|
||||||
, connEscapeName conn $ fieldDB $ entityId t
|
|
||||||
, " FROM "
|
|
||||||
, connEscapeName conn temp
|
|
||||||
, ") ) "
|
|
||||||
]
|
|
||||||
sql = mconcat
|
|
||||||
[ sqlWith
|
|
||||||
, "UPDATE "
|
|
||||||
, connEscapeName conn $ entityDB t
|
|
||||||
, " SET "
|
|
||||||
, T.intercalate "," $ map (go' . go) upds
|
|
||||||
, wher
|
|
||||||
]
|
|
||||||
vals =
|
|
||||||
getFiltsValues conn [isRoot] ++
|
|
||||||
map updatePersistValue upds ++
|
|
||||||
getFiltsValues conn filts
|
|
||||||
|
|
||||||
withRecursive
|
|
||||||
:: (PersistEntity val, SqlBackend ~ PersistEntityBackend val)
|
|
||||||
=> RecursionDirection
|
|
||||||
-> EntityField val (Maybe (Key val))
|
|
||||||
-> Key val
|
|
||||||
-> SqlBackend
|
|
||||||
-> EntityDef
|
|
||||||
-> (SqlBackend -> EntityDef -> [Text])
|
|
||||||
-> (DBName, Filter val, Text, DBName -> Text, Text)
|
|
||||||
withRecursive dir field root conn t getcols =
|
|
||||||
let temp = DBName "temp_hierarchy_cte"
|
|
||||||
isRoot = persistIdField ==. root
|
|
||||||
cols = T.intercalate "," $ getcols conn t
|
|
||||||
qcols name =
|
|
||||||
T.intercalate ", " $
|
|
||||||
map ((connEscapeName conn name <>) . ("." <>)) $
|
|
||||||
getcols conn t
|
|
||||||
sql = mconcat
|
|
||||||
[ "WITH RECURSIVE "
|
|
||||||
, connEscapeName conn temp
|
|
||||||
, "("
|
|
||||||
, cols
|
|
||||||
, ") AS ( SELECT "
|
|
||||||
, cols
|
|
||||||
, " FROM "
|
|
||||||
, connEscapeName conn $ entityDB t
|
|
||||||
, filterClause False conn [isRoot]
|
|
||||||
--, " WHERE "
|
|
||||||
--, connEscapeName conn $ fieldDB $ entityId t
|
|
||||||
--, " = ?"
|
|
||||||
, " UNION SELECT "
|
|
||||||
, qcols $ entityDB t
|
|
||||||
, " FROM "
|
|
||||||
, connEscapeName conn $ entityDB t
|
|
||||||
, ", "
|
|
||||||
, connEscapeName conn temp
|
|
||||||
, " WHERE "
|
|
||||||
, connEscapeName conn $ entityDB t
|
|
||||||
, "."
|
|
||||||
, connEscapeName conn $ fieldDB $ case dir of
|
|
||||||
Ancestors -> persistFieldDef field
|
|
||||||
Decendants -> entityId t
|
|
||||||
, " = "
|
|
||||||
, connEscapeName conn temp
|
|
||||||
, "."
|
|
||||||
, connEscapeName conn $ fieldDB $ case dir of
|
|
||||||
Ancestors -> entityId t
|
|
||||||
Decendants -> persistFieldDef field
|
|
||||||
, " ) "
|
|
||||||
]
|
|
||||||
in (temp, isRoot, cols, qcols, sql)
|
|
||||||
|
|
@ -1,421 +0,0 @@
|
||||||
{- 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 (empty, singleton, 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
|
|
||||||
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
|
|
||||||
|
|
||||||
-- HACK NOTE
|
|
||||||
-- The filter refers to the edge table, but in undirectional cases we
|
|
||||||
-- use a temporary uedge table instead. Some possible ways to fix that
|
|
||||||
-- are:
|
|
||||||
--
|
|
||||||
-- * Use 'filterClause' and then apply some text replacement function
|
|
||||||
-- from "Data.Text" to fix the table name
|
|
||||||
-- * Write a modified 'filterClause' that lets me pick a table name
|
|
||||||
-- * Since we already create a temporary uedge table anyway, apply the
|
|
||||||
-- filter there instead of here in the recursive step
|
|
||||||
--
|
|
||||||
-- In the code below I'm taking the 3rd approach.
|
|
||||||
--
|
|
||||||
-- At the time of writing, the SQL is a bit ugly: The uedge table is
|
|
||||||
-- created by an UNION of @SELECT u, v@ and SELECT v, u@, each of these
|
|
||||||
-- applied the filter separately. Feel free to offer and write cleaner
|
|
||||||
-- nicer SQL for this.
|
|
||||||
filt = filterClause False conn filter
|
|
||||||
fvals = getFiltsValues conn filter
|
|
||||||
sqlStep forward backward edge' filt' = mconcat
|
|
||||||
[ "SELECT "
|
|
||||||
, edge' ^* fieldDB forward, ", "
|
|
||||||
, temp ^* tpath, " || ", edge' ^* fieldDB forward, ", "
|
|
||||||
, edge' ^* fieldDB forward, " = ANY(", temp ^* tpath, ")"
|
|
||||||
, " FROM ", edge' <#> temp
|
|
||||||
, " ON ", edge' ^* fieldDB backward, " = ", temp ^* tid
|
|
||||||
, if T.null filt'
|
|
||||||
then " WHERE NOT " <> temp ^* tcycle
|
|
||||||
else filt' <> " AND NOT " <> temp ^* tcycle
|
|
||||||
]
|
|
||||||
|
|
||||||
sql = mconcat
|
|
||||||
[ "WITH RECURSIVE "
|
|
||||||
, case follow of
|
|
||||||
FollowBoth -> sqlUEdge dbname filt tEdge bwd fwd <> ", "
|
|
||||||
_ -> T.empty
|
|
||||||
, 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
|
|
||||||
, case msource of
|
|
||||||
Nothing -> T.empty
|
|
||||||
Just l -> mconcat
|
|
||||||
[ " WHERE ", entityDB tNode ^* fieldDB (entityId tNode)
|
|
||||||
, " IN ("
|
|
||||||
, T.intercalate ", " $
|
|
||||||
replicate (length l) (T.singleton '?')
|
|
||||||
, ")"
|
|
||||||
]
|
|
||||||
, " UNION ALL "
|
|
||||||
, case follow of
|
|
||||||
FollowForward -> sqlStep fwd bwd (entityDB tEdge) filt
|
|
||||||
FollowBackward -> sqlStep bwd fwd (entityDB tEdge) filt
|
|
||||||
FollowBoth -> sqlStep fwd bwd uedge T.empty
|
|
||||||
, " ) SELECT 1 WHERE EXISTS ( SELECT ", temp ^* tpath
|
|
||||||
, " FROM ", dbname temp
|
|
||||||
, case mdest of
|
|
||||||
Nothing -> T.empty
|
|
||||||
Just l -> mconcat
|
|
||||||
[ " WHERE ", temp ^* tid, " IN ("
|
|
||||||
, T.intercalate ", " $
|
|
||||||
replicate (length l) (T.singleton '?')
|
|
||||||
, ")"
|
|
||||||
]
|
|
||||||
, case mlen of
|
|
||||||
Nothing -> T.empty
|
|
||||||
Just _ -> " AND array_length(" <> temp ^* tpath <> ", 1) <= ?"
|
|
||||||
, " )"
|
|
||||||
]
|
|
||||||
toP = fmap toPersistValue
|
|
||||||
toPL = fmap $ 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 []
|
|
||||||
|
|
@ -1,296 +0,0 @@
|
||||||
{- 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 (empty, singleton, 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
|
|
||||||
-- > temp (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
|
|
||||||
-- > 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
|
|
||||||
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 l -> mconcat
|
|
||||||
[ " FROM ", dbname $ entityDB tNode
|
|
||||||
, " WHERE ", entityDB tNode ^* fieldDB (entityId tNode)
|
|
||||||
, " IN ("
|
|
||||||
, T.intercalate ", " $
|
|
||||||
replicate (length l) (T.singleton '?')
|
|
||||||
, ")"
|
|
||||||
]
|
|
||||||
]
|
|
||||||
|
|
||||||
filt = filterClause False conn filter
|
|
||||||
fvals = getFiltsValues conn filter
|
|
||||||
sqlStep forward backward edge' filt' = mconcat
|
|
||||||
[ "SELECT "
|
|
||||||
, edge' ^* fieldDB forward, ", "
|
|
||||||
, temp ^* tpath, " || ", edge' ^* fieldDB forward, ", "
|
|
||||||
, edge' ^* fieldDB forward, " = ANY(", temp ^* tpath, ")"
|
|
||||||
, " FROM ", edge' <#> temp
|
|
||||||
, " ON ", edge' ^* 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 "
|
|
||||||
, case follow of
|
|
||||||
FollowBoth -> sqlUEdge dbname filt tEdge bwd fwd <> ", "
|
|
||||||
_ -> T.empty
|
|
||||||
, dbname temp
|
|
||||||
, " ("
|
|
||||||
, T.intercalate "," $ map dbname [tid, tpath, tcycle]
|
|
||||||
, ") AS ("
|
|
||||||
, sqlStart
|
|
||||||
|
|
||||||
, " UNION ALL "
|
|
||||||
, case follow of
|
|
||||||
FollowForward -> sqlStep fwd bwd (entityDB tEdge) filt
|
|
||||||
FollowBackward -> sqlStep bwd fwd (entityDB tEdge) filt
|
|
||||||
FollowBoth -> sqlStep fwd bwd uedge T.empty
|
|
||||||
, " ) "
|
|
||||||
, 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"
|
|
||||||
]
|
|
||||||
]
|
|
||||||
toPL = fmap $ map toPersistValue
|
|
||||||
vals = toPL minitials ?++ 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 []
|
|
||||||
|
|
@ -1,425 +0,0 @@
|
||||||
{- 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 (empty, singleton, 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
|
|
||||||
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 edge' filt' = mconcat
|
|
||||||
[ "SELECT "
|
|
||||||
, edge' ^* fieldDB forward, ", "
|
|
||||||
, temp ^* tpath, " || ", edge' ^* fieldDB forward, ", "
|
|
||||||
, edge' ^* fieldDB forward, " = ANY(", temp ^* tpath, ")"
|
|
||||||
, " FROM ", edge' <#> temp
|
|
||||||
, " ON ", edge' ^* fieldDB backward, " = ", temp ^* tid
|
|
||||||
, if T.null filt'
|
|
||||||
then " WHERE NOT " <> temp ^* tcycle
|
|
||||||
else filt' <> " AND NOT " <> temp ^* tcycle
|
|
||||||
]
|
|
||||||
|
|
||||||
sql = mconcat
|
|
||||||
[ "WITH RECURSIVE "
|
|
||||||
, case follow of
|
|
||||||
FollowBoth -> sqlUEdge dbname filt tEdge bwd fwd <> ", "
|
|
||||||
_ -> T.empty
|
|
||||||
, 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
|
|
||||||
, case msource of
|
|
||||||
Nothing -> T.empty
|
|
||||||
Just l -> mconcat
|
|
||||||
[ " WHERE ", entityDB tNode ^* fieldDB (entityId tNode)
|
|
||||||
, " IN ("
|
|
||||||
, T.intercalate ", " $
|
|
||||||
replicate (length l) (T.singleton '?')
|
|
||||||
, ")"
|
|
||||||
]
|
|
||||||
, " UNION ALL "
|
|
||||||
, case follow of
|
|
||||||
FollowForward -> sqlStep fwd bwd (entityDB tEdge) filt
|
|
||||||
FollowBackward -> sqlStep bwd fwd (entityDB tEdge) filt
|
|
||||||
FollowBoth -> sqlStep fwd bwd uedge T.empty
|
|
||||||
, " ) SELECT ", temp ^* tpath
|
|
||||||
, " FROM ", dbname temp
|
|
||||||
, case mdest of
|
|
||||||
Nothing -> T.empty
|
|
||||||
Just l -> mconcat
|
|
||||||
[ " WHERE ", temp ^* tid
|
|
||||||
, " IN ("
|
|
||||||
, T.intercalate ", " $
|
|
||||||
replicate (length l) (T.singleton '?')
|
|
||||||
, ")"
|
|
||||||
]
|
|
||||||
, case mlen of
|
|
||||||
Nothing -> T.empty
|
|
||||||
Just _ -> " AND array_length(" <> temp ^* tpath <> ", 1) <= ?"
|
|
||||||
, " ORDER BY array_length(", temp ^* tpath, ", 1)"
|
|
||||||
, case mlim of
|
|
||||||
Nothing -> T.empty
|
|
||||||
Just _ -> " LIMIT ?"
|
|
||||||
]
|
|
||||||
toP = fmap toPersistValue
|
|
||||||
toPL = fmap $ 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 []
|
|
||||||
|
|
@ -1,199 +0,0 @@
|
||||||
{- 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 (empty, singleton, 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
|
|
||||||
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 edge' filt' = mconcat
|
|
||||||
[ "SELECT "
|
|
||||||
, edge' ^* fieldDB forward, ", "
|
|
||||||
, temp ^* tpath, " || ", edge' ^* fieldDB forward, ", "
|
|
||||||
, edge' ^* fieldDB forward, " = ANY(", temp ^* tpath, ")"
|
|
||||||
, " FROM ", edge' <#> temp
|
|
||||||
, " ON ", edge' ^* fieldDB backward, " = ", temp ^* tid
|
|
||||||
, if T.null filt'
|
|
||||||
then " WHERE NOT " <> temp ^* tcycle
|
|
||||||
else filt' <> " AND NOT " <> temp ^* tcycle
|
|
||||||
]
|
|
||||||
|
|
||||||
sql = mconcat
|
|
||||||
[ "WITH RECURSIVE "
|
|
||||||
, case follow of
|
|
||||||
FollowBoth -> sqlUEdge dbname filt tEdge bwd fwd <> ", "
|
|
||||||
_ -> T.empty
|
|
||||||
, 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 ("
|
|
||||||
, T.intercalate ", " $
|
|
||||||
replicate (length initials) (T.singleton '?')
|
|
||||||
, ")"
|
|
||||||
, " UNION ALL "
|
|
||||||
, case follow of
|
|
||||||
FollowForward -> sqlStep fwd bwd (entityDB tEdge) filt
|
|
||||||
FollowBackward -> sqlStep bwd fwd (entityDB tEdge) filt
|
|
||||||
FollowBoth -> sqlStep fwd bwd uedge T.empty
|
|
||||||
, " ) SELECT DISTINCT ", temp ^* tid
|
|
||||||
, " FROM ", dbname temp
|
|
||||||
, " WHERE NOT ", temp ^* tcycle
|
|
||||||
, " AND array_length(", temp ^* tpath, ", 1) "
|
|
||||||
, case mlen of
|
|
||||||
Nothing -> ">= 2"
|
|
||||||
Just _ -> "BETWEEN 2 AND ?"
|
|
||||||
]
|
|
||||||
toP = fmap toPersistValue
|
|
||||||
toPL = 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 []
|
|
||||||
|
|
@ -1,301 +0,0 @@
|
||||||
{- 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
|
|
||||||
, trrFix
|
|
||||||
)
|
|
||||||
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 edge.*
|
|
||||||
-- > FROM edge INNER JOIN temp
|
|
||||||
-- > ON edge.source = temp.path[1] AND
|
|
||||||
-- > edge.dest = temp.id
|
|
||||||
-- > WHERE array_length(temp.path, 1) > 2 AND
|
|
||||||
-- > 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
|
|
||||||
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
|
|
||||||
, " UNION ALL "
|
|
||||||
, sqlStep fwd bwd
|
|
||||||
, " )"
|
|
||||||
, " SELECT ", ecols
|
|
||||||
, " FROM ", dbname $ entityDB tEdge
|
|
||||||
, " EXCEPT "
|
|
||||||
, " SELECT ", qecols $ entityDB tEdge
|
|
||||||
, " FROM ", entityDB tEdge <#> temp
|
|
||||||
, " ON "
|
|
||||||
, entityDB tEdge ^* fieldDB bwd, " = ", temp ^* tpath, "[1] AND "
|
|
||||||
, entityDB tEdge ^* fieldDB fwd, " = ", temp ^* tid
|
|
||||||
, " WHERE array_length(", temp ^* tpath, ", 1) > 2 AND 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 edge.id
|
|
||||||
-- > FROM edge INNER JOIN temp
|
|
||||||
-- > ON edge.source = temp.path[1] AND
|
|
||||||
-- > edge.dest = temp.id
|
|
||||||
-- > WHERE array_length(temp.path, 1) > 2 AND
|
|
||||||
-- > 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
|
|
||||||
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
|
|
||||||
, " UNION ALL "
|
|
||||||
, sqlStep fwd bwd
|
|
||||||
, " ) DELETE FROM ", dbname $ entityDB tEdge
|
|
||||||
, " WHERE ", entityDB tEdge ^* fieldDB (entityId tEdge), " IN ("
|
|
||||||
, " SELECT ", entityDB tEdge ^* fieldDB (entityId tEdge)
|
|
||||||
, " FROM ", entityDB tEdge <#> temp
|
|
||||||
, " ON "
|
|
||||||
, entityDB tEdge ^* fieldDB bwd, " = ", temp ^* tpath
|
|
||||||
, "[1] AND ", entityDB tEdge ^* fieldDB fwd, " = ", temp ^* tid
|
|
||||||
, " WHERE array_length(", temp ^* tpath, ", 1) > 2 AND NOT "
|
|
||||||
, temp ^* tcycle
|
|
||||||
, " )"
|
|
||||||
]
|
|
||||||
rawExecuteCount sql []
|
|
||||||
|
|
||||||
-- | Given an edge (u, v) that was just added to a reduced DAG, remove edges if
|
|
||||||
-- necessary to make sure the graph stays reduced.
|
|
||||||
--
|
|
||||||
-- It more-or-less looks like this:
|
|
||||||
--
|
|
||||||
-- > WITH RECURSIVE
|
|
||||||
-- > temp (id, path, cycle, contains) AS (
|
|
||||||
-- > SELECT node.id, ARRAY[node.id], FALSE, FALSE
|
|
||||||
-- > FROM node
|
|
||||||
-- > UNION ALL
|
|
||||||
-- > SELECT edge.dest,
|
|
||||||
-- > temp.path || edge.dest,
|
|
||||||
-- > edge.dest = ANY(temp.path),
|
|
||||||
-- > temp.contains OR edge.dest = v
|
|
||||||
-- > FROM edge INNER JOIN temp
|
|
||||||
-- > ON edge.source = temp.id
|
|
||||||
-- > WHERE NOT temp.cycle AND
|
|
||||||
-- > ( edge.source = u AND edge.dest = v OR
|
|
||||||
-- > edge.source <> u AND edge.dest <> v
|
|
||||||
-- > )
|
|
||||||
-- > )
|
|
||||||
-- > DELETE FROM edge
|
|
||||||
-- > WHERE id IN (
|
|
||||||
-- > SELECT edge.id
|
|
||||||
-- > FROM edge INNER JOIN temp
|
|
||||||
-- > ON edge.source = temp.path[1] AND
|
|
||||||
-- > edge.dest = temp.id
|
|
||||||
-- > WHERE array_length(temp.path, 1) > 2 AND
|
|
||||||
-- > NOT temp.cycle AND
|
|
||||||
-- > temp.contains
|
|
||||||
-- > )
|
|
||||||
trrFix
|
|
||||||
:: ( MonadIO m
|
|
||||||
, PersistEntityGraph node edge
|
|
||||||
, SqlBackend ~ PersistEntityBackend node
|
|
||||||
, SqlBackend ~ PersistEntityBackend edge
|
|
||||||
)
|
|
||||||
=> edge
|
|
||||||
-> Proxy (node, edge)
|
|
||||||
-> ReaderT SqlBackend m Int64
|
|
||||||
trrFix edge proxy = do
|
|
||||||
conn <- ask
|
|
||||||
let from = sourceParamFromProxy proxy edge
|
|
||||||
to = destParamFromProxy proxy edge
|
|
||||||
tNode = entityDef $ dummyFromFst proxy
|
|
||||||
tEdge = entityDef $ dummyFromSnd proxy
|
|
||||||
fwd = persistFieldDef $ destFieldFromProxy proxy
|
|
||||||
bwd = persistFieldDef $ sourceFieldFromProxy proxy
|
|
||||||
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, "),"
|
|
||||||
, temp ^* tcontains, " OR "
|
|
||||||
, entityDB tEdge ^* fieldDB forward, " = ?"
|
|
||||||
, " FROM ", entityDB tEdge <#> temp
|
|
||||||
, " ON ", entityDB tEdge ^* fieldDB backward, " = ", temp ^* tid
|
|
||||||
, " WHERE NOT ", temp ^* tcycle, " AND ("
|
|
||||||
, entityDB tEdge ^* fieldDB backward, " = ? AND "
|
|
||||||
, entityDB tEdge ^* fieldDB forward, " = ?"
|
|
||||||
, " OR "
|
|
||||||
, entityDB tEdge ^* fieldDB backward, " <> ? AND "
|
|
||||||
, entityDB tEdge ^* fieldDB forward, " <> ?"
|
|
||||||
, ")"
|
|
||||||
]
|
|
||||||
|
|
||||||
sql = mconcat
|
|
||||||
[ "WITH RECURSIVE "
|
|
||||||
, dbname temp
|
|
||||||
, " ("
|
|
||||||
, T.intercalate "," $ map dbname [tid, tpath, tcycle, tcontains]
|
|
||||||
, ") AS ( SELECT "
|
|
||||||
, entityDB tNode ^* fieldDB (entityId tNode), ", "
|
|
||||||
, "ARRAY[", entityDB tNode ^* fieldDB (entityId tNode), "], "
|
|
||||||
, "FALSE, FALSE"
|
|
||||||
, " FROM ", dbname $ entityDB tNode
|
|
||||||
, " UNION ALL "
|
|
||||||
, sqlStep fwd bwd
|
|
||||||
, " ) DELETE FROM ", dbname $ entityDB tEdge
|
|
||||||
, " WHERE ", entityDB tEdge ^* fieldDB (entityId tEdge), " IN ("
|
|
||||||
, " SELECT ", entityDB tEdge ^* fieldDB (entityId tEdge)
|
|
||||||
, " FROM ", entityDB tEdge <#> temp
|
|
||||||
, " ON "
|
|
||||||
, entityDB tEdge ^* fieldDB bwd, " = ", temp ^* tpath
|
|
||||||
, "[1] AND ", entityDB tEdge ^* fieldDB fwd, " = ", temp ^* tid
|
|
||||||
, " WHERE array_length(", temp ^* tpath, ", 1) > 2 AND NOT "
|
|
||||||
, temp ^* tcycle, " AND ", temp ^* tcontains
|
|
||||||
, " )"
|
|
||||||
]
|
|
||||||
u = toPersistValue from
|
|
||||||
v = toPersistValue to
|
|
||||||
rawExecuteCount sql [v, u, v, u, v]
|
|
||||||
|
|
@ -26,7 +26,7 @@ import Text.Email.Validate (EmailAddress)
|
||||||
import Yesod.Auth.Account (PersistUserCredentials (..))
|
import Yesod.Auth.Account (PersistUserCredentials (..))
|
||||||
|
|
||||||
import Database.Persist.EmailAddress
|
import Database.Persist.EmailAddress
|
||||||
import Database.Persist.Local.Class.PersistEntityGraph
|
import Database.Persist.Graph.Class
|
||||||
|
|
||||||
import Vervis.Model.Group
|
import Vervis.Model.Group
|
||||||
import Vervis.Model.Ident
|
import Vervis.Model.Ident
|
||||||
|
|
|
||||||
|
|
@ -35,8 +35,8 @@ import Database.Persist.Sql.Util
|
||||||
|
|
||||||
import qualified Data.Text as T (intercalate)
|
import qualified Data.Text as T (intercalate)
|
||||||
|
|
||||||
import Database.Persist.Local.Class.PersistQueryForest
|
import Database.Persist.Graph.Class
|
||||||
import Database.Persist.Local.Sql
|
import Database.Persist.Graph.SQL
|
||||||
import Vervis.Model
|
import Vervis.Model
|
||||||
import Vervis.Model.Role
|
import Vervis.Model.Role
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -20,8 +20,9 @@ packages:
|
||||||
- lib/hit-network
|
- lib/hit-network
|
||||||
- lib/http-client-signature
|
- lib/http-client-signature
|
||||||
- lib/http-signature
|
- lib/http-signature
|
||||||
- lib/persistent-migration
|
|
||||||
- lib/persistent-email-address
|
- lib/persistent-email-address
|
||||||
|
- lib/persistent-graph
|
||||||
|
- lib/persistent-migration
|
||||||
- lib/time-interval-aeson
|
- lib/time-interval-aeson
|
||||||
# - lib/yesod-auth-account
|
# - lib/yesod-auth-account
|
||||||
- location:
|
- location:
|
||||||
|
|
|
||||||
11
vervis.cabal
11
vervis.cabal
|
|
@ -68,19 +68,9 @@ library
|
||||||
Data.Tree.Local
|
Data.Tree.Local
|
||||||
Database.Esqueleto.Local
|
Database.Esqueleto.Local
|
||||||
Database.Persist.Class.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.Sql.Local
|
||||||
Database.Persist.Local.Class.PersistEntityGraph
|
|
||||||
Database.Persist.Local.Class.PersistEntityHierarchy
|
Database.Persist.Local.Class.PersistEntityHierarchy
|
||||||
Database.Persist.Local.Class.PersistQueryForest
|
|
||||||
Database.Persist.Local.RecursionDoc
|
Database.Persist.Local.RecursionDoc
|
||||||
Database.Persist.Local.Sql
|
|
||||||
Database.Persist.Local.Sql.Orphan.Common
|
|
||||||
Database.Persist.Local.Sql.Orphan.PersistQueryForest
|
|
||||||
Diagrams.IntransitiveDAG
|
Diagrams.IntransitiveDAG
|
||||||
Formatting.CaseInsensitive
|
Formatting.CaseInsensitive
|
||||||
Language.Haskell.TH.Quote.Local
|
Language.Haskell.TH.Quote.Local
|
||||||
|
|
@ -296,6 +286,7 @@ library
|
||||||
, pem
|
, pem
|
||||||
, persistent
|
, persistent
|
||||||
, persistent-email-address
|
, persistent-email-address
|
||||||
|
, persistent-graph
|
||||||
, persistent-migration
|
, persistent-migration
|
||||||
, persistent-postgresql
|
, persistent-postgresql
|
||||||
, persistent-template
|
, persistent-template
|
||||||
|
|
|
||||||
Loading…
Reference in a new issue