From 250701712a8db690fae000dde554cf8aeb214540 Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Sat, 26 Jan 2019 22:20:19 +0000 Subject: [PATCH] Move most of the DB graph modules to a separate persistent-graph library --- .../Persist/Local/Class/PersistEntityGraph.hs | 45 -- .../Local/Class/PersistEntityHierarchy.hs | 2 +- .../Persist/Local/Class/PersistQueryForest.hs | 180 -------- src/Database/Persist/Local/Sql.hs | 279 ------------ .../Persist/Local/Sql/Orphan/Common.hs | 234 ---------- .../Local/Sql/Orphan/PersistQueryForest.hs | 333 -------------- src/Database/Persist/Sql/Graph/Connects.hs | 421 ----------------- src/Database/Persist/Sql/Graph/Cyclic.hs | 296 ------------ src/Database/Persist/Sql/Graph/Path.hs | 425 ------------------ src/Database/Persist/Sql/Graph/Reachable.hs | 199 -------- .../Persist/Sql/Graph/TransitiveReduction.hs | 301 ------------- src/Vervis/Model.hs | 2 +- src/Vervis/Query.hs | 4 +- stack.yaml | 3 +- vervis.cabal | 11 +- 15 files changed, 7 insertions(+), 2728 deletions(-) delete mode 100644 src/Database/Persist/Local/Class/PersistEntityGraph.hs delete mode 100644 src/Database/Persist/Local/Class/PersistQueryForest.hs delete mode 100644 src/Database/Persist/Local/Sql.hs delete mode 100644 src/Database/Persist/Local/Sql/Orphan/Common.hs delete mode 100644 src/Database/Persist/Local/Sql/Orphan/PersistQueryForest.hs delete mode 100644 src/Database/Persist/Sql/Graph/Connects.hs delete mode 100644 src/Database/Persist/Sql/Graph/Cyclic.hs delete mode 100644 src/Database/Persist/Sql/Graph/Path.hs delete mode 100644 src/Database/Persist/Sql/Graph/Reachable.hs delete mode 100644 src/Database/Persist/Sql/Graph/TransitiveReduction.hs diff --git a/src/Database/Persist/Local/Class/PersistEntityGraph.hs b/src/Database/Persist/Local/Class/PersistEntityGraph.hs deleted file mode 100644 index 28739a0..0000000 --- a/src/Database/Persist/Local/Class/PersistEntityGraph.hs +++ /dev/null @@ -1,45 +0,0 @@ -{- This file is part of Vervis. - - - - Written in 2016 by fr33domlover . - - - - ♡ Copying is an act of love. Please copy, reuse and share. - - - - The author(s) have dedicated all copyright and related and neighboring - - rights to this software to the public domain worldwide. This software is - - distributed without any warranty. - - - - You should have received a copy of the CC0 Public Domain Dedication along - - with this software. If not, see - - . - -} - -module Database.Persist.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 diff --git a/src/Database/Persist/Local/Class/PersistEntityHierarchy.hs b/src/Database/Persist/Local/Class/PersistEntityHierarchy.hs index bb29ec9..9497a9b 100644 --- a/src/Database/Persist/Local/Class/PersistEntityHierarchy.hs +++ b/src/Database/Persist/Local/Class/PersistEntityHierarchy.hs @@ -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 diff --git a/src/Database/Persist/Local/Class/PersistQueryForest.hs b/src/Database/Persist/Local/Class/PersistQueryForest.hs deleted file mode 100644 index 01fa563..0000000 --- a/src/Database/Persist/Local/Class/PersistQueryForest.hs +++ /dev/null @@ -1,180 +0,0 @@ -{- This file is part of Vervis. - - - - Written in 2016 by fr33domlover . - - - - ♡ Copying is an act of love. Please copy, reuse and share. - - - - The author(s) have dedicated all copyright and related and neighboring - - rights to this software to the public domain worldwide. This software is - - distributed without any warranty. - - - - You should have received a copy of the CC0 Public Domain Dedication along - - with this software. If not, see - - . - -} - -module Database.Persist.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) diff --git a/src/Database/Persist/Local/Sql.hs b/src/Database/Persist/Local/Sql.hs deleted file mode 100644 index 6df4dce..0000000 --- a/src/Database/Persist/Local/Sql.hs +++ /dev/null @@ -1,279 +0,0 @@ -{- This file is part of Vervis. - - - - Written in 2016 by fr33domlover . - - - - ♡ Copying is an act of love. Please copy, reuse and share. - - - - The author(s) have dedicated all copyright and related and neighboring - - rights to this software to the public domain worldwide. This software is - - distributed without any warranty. - - - - You should have received a copy of the CC0 Public Domain Dedication along - - with this software. If not, see - - . - -} - -module Database.Persist.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 diff --git a/src/Database/Persist/Local/Sql/Orphan/Common.hs b/src/Database/Persist/Local/Sql/Orphan/Common.hs deleted file mode 100644 index e2529aa..0000000 --- a/src/Database/Persist/Local/Sql/Orphan/Common.hs +++ /dev/null @@ -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 diff --git a/src/Database/Persist/Local/Sql/Orphan/PersistQueryForest.hs b/src/Database/Persist/Local/Sql/Orphan/PersistQueryForest.hs deleted file mode 100644 index 2fed67e..0000000 --- a/src/Database/Persist/Local/Sql/Orphan/PersistQueryForest.hs +++ /dev/null @@ -1,333 +0,0 @@ -{- This file is part of Vervis. - - - - Written in 2016 by fr33domlover . - - - - ♡ Copying is an act of love. Please copy, reuse and share. - - - - The author(s) have dedicated all copyright and related and neighboring - - rights to this software to the public domain worldwide. This software is - - distributed without any warranty. - - - - You should have received a copy of the CC0 Public Domain Dedication along - - with this software. If not, see - - . - -} - -module Database.Persist.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) diff --git a/src/Database/Persist/Sql/Graph/Connects.hs b/src/Database/Persist/Sql/Graph/Connects.hs deleted file mode 100644 index f20aadb..0000000 --- a/src/Database/Persist/Sql/Graph/Connects.hs +++ /dev/null @@ -1,421 +0,0 @@ -{- This file is part of Vervis. - - - - Written in 2016 by fr33domlover . - - - - ♡ Copying is an act of love. Please copy, reuse and share. - - - - The author(s) have dedicated all copyright and related and neighboring - - rights to this software to the public domain worldwide. This software is - - distributed without any warranty. - - - - You should have received a copy of the CC0 Public Domain Dedication along - - with this software. If not, see - - . - -} - -module Database.Persist.Sql.Graph.Connects - ( -- * Checking for reachability, i.e. existence of path - -- $connects - -- ** Standard - connects - , mconnects - , connectsm - , mconnectsm - , xconnects - , xmconnects - , xconnectsm - , xmconnectsm - -- ** Undirected - , uconnects - , umconnects - , uconnectsm - , umconnectsm - -- ** Reversed - , rconnects - , rmconnects - , rconnectsm - , rmconnectsm - ) -where - -import Prelude - -import Control.Monad.IO.Class (MonadIO) -import Control.Monad.Trans.Reader (ReaderT, ask) -import Data.Int (Int64) -import Data.Monoid ((<>)) -import Data.Proxy (Proxy) -import Data.Text (Text) -import Database.Persist -import Database.Persist.Sql -import Database.Persist.Sql.Util - -import qualified Data.Text as T (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 [] diff --git a/src/Database/Persist/Sql/Graph/Cyclic.hs b/src/Database/Persist/Sql/Graph/Cyclic.hs deleted file mode 100644 index 83578be..0000000 --- a/src/Database/Persist/Sql/Graph/Cyclic.hs +++ /dev/null @@ -1,296 +0,0 @@ -{- This file is part of Vervis. - - - - Written in 2016 by fr33domlover . - - - - ♡ Copying is an act of love. Please copy, reuse and share. - - - - The author(s) have dedicated all copyright and related and neighboring - - rights to this software to the public domain worldwide. This software is - - distributed without any warranty. - - - - You should have received a copy of the CC0 Public Domain Dedication along - - with this software. If not, see - - . - -} - -module Database.Persist.Sql.Graph.Cyclic - ( -- * Checking for cycle existence - -- $cyclic - -- ** Standard - cyclic - , cyclicn - , xcyclic - , xcyclicn - -- ** Undirected - , ucyclic - , ucyclicn - -- ** Reversed - , rcyclic - , rcyclicn - ) -where - -import Prelude - -import Control.Monad.IO.Class (MonadIO) -import Control.Monad.Trans.Reader (ReaderT, ask) -import Data.Int (Int64) -import Data.Monoid ((<>)) -import Data.Proxy (Proxy) -import Data.Text (Text) -import Database.Persist -import Database.Persist.Sql -import Database.Persist.Sql.Util - -import qualified Data.Text as T (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 [] diff --git a/src/Database/Persist/Sql/Graph/Path.hs b/src/Database/Persist/Sql/Graph/Path.hs deleted file mode 100644 index 3ba166d..0000000 --- a/src/Database/Persist/Sql/Graph/Path.hs +++ /dev/null @@ -1,425 +0,0 @@ -{- This file is part of Vervis. - - - - Written in 2016 by fr33domlover . - - - - ♡ Copying is an act of love. Please copy, reuse and share. - - - - The author(s) have dedicated all copyright and related and neighboring - - rights to this software to the public domain worldwide. This software is - - distributed without any warranty. - - - - You should have received a copy of the CC0 Public Domain Dedication along - - with this software. If not, see - - . - -} - -module Database.Persist.Sql.Graph.Path - ( -- * Finding paths - -- $path - -- ** Standard - path - , mpath - , pathm - , mpathm - , xpath - , xmpath - , xpathm - , xmpathm - -- ** Undirected - , upath - , umpath - , upathm - , umpathm - -- ** Reversed - , rpath - , rmpath - , rpathm - , rmpathm - ) -where - -import Prelude - -import Control.Monad.IO.Class (MonadIO) -import Control.Monad.Trans.Reader (ReaderT, ask) -import Data.Int (Int64) -import Data.Monoid ((<>)) -import Data.Proxy (Proxy) -import Data.Text (Text) -import Database.Persist -import Database.Persist.Sql -import Database.Persist.Sql.Util - -import qualified Data.Text as T (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 [] diff --git a/src/Database/Persist/Sql/Graph/Reachable.hs b/src/Database/Persist/Sql/Graph/Reachable.hs deleted file mode 100644 index 6de5ee0..0000000 --- a/src/Database/Persist/Sql/Graph/Reachable.hs +++ /dev/null @@ -1,199 +0,0 @@ -{- This file is part of Vervis. - - - - Written in 2016 by fr33domlover . - - - - ♡ Copying is an act of love. Please copy, reuse and share. - - - - The author(s) have dedicated all copyright and related and neighboring - - rights to this software to the public domain worldwide. This software is - - distributed without any warranty. - - - - You should have received a copy of the CC0 Public Domain Dedication along - - with this software. If not, see - - . - -} - -module Database.Persist.Sql.Graph.Reachable - ( -- * Finding the nodes reachable from a given node or set of nodes - -- $reachable - -- ** Standard - reachable - , xreachable - -- ** Undirected - , ureachable - -- ** Reversed - , rreachable - ) -where - -import Prelude - -import Control.Monad.IO.Class (MonadIO) -import Control.Monad.Trans.Reader (ReaderT, ask) -import Data.Int (Int64) -import Data.Monoid ((<>)) -import Data.Proxy (Proxy) -import Data.Text (Text) -import Database.Persist -import Database.Persist.Sql -import Database.Persist.Sql.Util - -import qualified Data.Text as T (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 [] diff --git a/src/Database/Persist/Sql/Graph/TransitiveReduction.hs b/src/Database/Persist/Sql/Graph/TransitiveReduction.hs deleted file mode 100644 index 03ef560..0000000 --- a/src/Database/Persist/Sql/Graph/TransitiveReduction.hs +++ /dev/null @@ -1,301 +0,0 @@ -{- This file is part of Vervis. - - - - Written in 2016 by fr33domlover . - - - - ♡ Copying is an act of love. Please copy, reuse and share. - - - - The author(s) have dedicated all copyright and related and neighboring - - rights to this software to the public domain worldwide. This software is - - distributed without any warranty. - - - - You should have received a copy of the CC0 Public Domain Dedication along - - with this software. If not, see - - . - -} - -module Database.Persist.Sql.Graph.TransitiveReduction - ( -- * Transitive reduction of DAGs - trrSelect - , trrApply - , 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] diff --git a/src/Vervis/Model.hs b/src/Vervis/Model.hs index a420f6b..c423252 100644 --- a/src/Vervis/Model.hs +++ b/src/Vervis/Model.hs @@ -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 diff --git a/src/Vervis/Query.hs b/src/Vervis/Query.hs index 1968d16..6c1e95e 100644 --- a/src/Vervis/Query.hs +++ b/src/Vervis/Query.hs @@ -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 diff --git a/stack.yaml b/stack.yaml index f291e4b..8e7b249 100644 --- a/stack.yaml +++ b/stack.yaml @@ -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: diff --git a/vervis.cabal b/vervis.cabal index 078d1c8..86dd9e6 100644 --- a/vervis.cabal +++ b/vervis.cabal @@ -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