forge/Vervis
1
0
Fork 0
Code Pull requests Activity

Move most of the DB graph modules to a separate persistent-graph library

Browse source
This commit is contained in:
fr33domlover 2019-01-26 22:20:19 +00:00
parent da6d8c008e
commit 250701712a
15 changed files with 7 additions and 2728 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

45
src/Database/Persist/Local/Class/PersistEntityGraph.hs
View file

@ -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

2
src/Database/Persist/Local/Class/PersistEntityHierarchy.hs
View file

@ -24,7 +24,7 @@ where
import Prelude
import Database.Persist
import Database.Persist.Local.Class.PersistEntityGraph
import Database.Persist.Graph.Class
data HierarchyEdgeDirection n e = TowardsChild | TowardsParent

180
src/Database/Persist/Local/Class/PersistQueryForest.hs
View file

@ -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)

279
src/Database/Persist/Local/Sql.hs
View file

@ -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

234
src/Database/Persist/Local/Sql/Orphan/Common.hs
View file

@ -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

333
src/Database/Persist/Local/Sql/Orphan/PersistQueryForest.hs
View file

@ -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)

421
src/Database/Persist/Sql/Graph/Connects.hs
View file

@ -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 []

296
src/Database/Persist/Sql/Graph/Cyclic.hs
View file

@ -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 []

425
src/Database/Persist/Sql/Graph/Path.hs
View file

@ -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 []

199
src/Database/Persist/Sql/Graph/Reachable.hs
View file

@ -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 []

301
src/Database/Persist/Sql/Graph/TransitiveReduction.hs
View file

@ -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]

2
src/Vervis/Model.hs
View file

@ -26,7 +26,7 @@ import Text.Email.Validate (EmailAddress)
import Yesod.Auth.Account (PersistUserCredentials (..))
import Database.Persist.EmailAddress
import Database.Persist.Local.Class.PersistEntityGraph
import Database.Persist.Graph.Class
import Vervis.Model.Group
import Vervis.Model.Ident

4
src/Vervis/Query.hs
View file

@ -35,8 +35,8 @@ import Database.Persist.Sql.Util
import qualified Data.Text as T (intercalate)
import Database.Persist.Local.Class.PersistQueryForest
import Database.Persist.Local.Sql
import Database.Persist.Graph.Class
import Database.Persist.Graph.SQL
import Vervis.Model
import Vervis.Model.Role

3
stack.yaml
View file

@ -20,8 +20,9 @@ packages:
- lib/hit-network
- lib/http-client-signature
- lib/http-signature
- lib/persistent-migration
- lib/persistent-email-address
- lib/persistent-graph
- lib/persistent-migration
- lib/time-interval-aeson
# - lib/yesod-auth-account
- location:

11
vervis.cabal
View file

@ -68,19 +68,9 @@ library
Data.Tree.Local
Database.Esqueleto.Local
Database.Persist.Class.Local
Database.Persist.Sql.Graph.Connects
Database.Persist.Sql.Graph.Cyclic
Database.Persist.Sql.Graph.Path
Database.Persist.Sql.Graph.Reachable
Database.Persist.Sql.Graph.TransitiveReduction
Database.Persist.Sql.Local
Database.Persist.Local.Class.PersistEntityGraph
Database.Persist.Local.Class.PersistEntityHierarchy
Database.Persist.Local.Class.PersistQueryForest
Database.Persist.Local.RecursionDoc
Database.Persist.Local.Sql
Database.Persist.Local.Sql.Orphan.Common
Database.Persist.Local.Sql.Orphan.PersistQueryForest
Diagrams.IntransitiveDAG
Formatting.CaseInsensitive
Language.Haskell.TH.Quote.Local
@ -296,6 +286,7 @@ library
, pem
, persistent
, persistent-email-address
, persistent-graph
, persistent-migration
, persistent-postgresql
, persistent-template