diff --git a/src/Database/Persist/Local/Class/PersistEntityGraph.hs b/src/Database/Persist/Local/Class/PersistEntityGraph.hs index cf4e6dd..815d85b 100644 --- a/src/Database/Persist/Local/Class/PersistEntityGraph.hs +++ b/src/Database/Persist/Local/Class/PersistEntityGraph.hs @@ -22,6 +22,7 @@ where import Prelude +import Data.Proxy (Proxy) import Database.Persist class (PersistEntity n, PersistEntity e) => PersistEntityGraph n e where @@ -30,10 +31,13 @@ class (PersistEntity n, PersistEntity e) => PersistEntityGraph n e where destParam :: e -> Key n destField :: EntityField e (Key n) -class PersistEntityGraph n e => PersistEntityGraphSelect n e where - type PersistEntityGraphSelector n e - selectorParam :: n -> PersistEntityGraphSelector n e - selectorField :: EntityField n (PersistEntityGraphSelector n e) +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 :: n -> Int diff --git a/src/Database/Persist/Local/Sql.hs b/src/Database/Persist/Local/Sql.hs index 2a1d4b8..f554728 100644 --- a/src/Database/Persist/Local/Sql.hs +++ b/src/Database/Persist/Local/Sql.hs @@ -32,6 +32,8 @@ module Database.Persist.Local.Sql , tcontains , sqlUEdge , FollowDirection (..) + , selectGraphNodesList + , selectGraphEdgesList ) where @@ -218,3 +220,60 @@ sqlUEdge dbname filt tEdge bwd fwd = in if T.null filt then sqlEdge $ entityDB tEdge else sqlBase <> sqlEdge ubase + +selectGraphNodesList + :: ( MonadIO m + , PersistEntityGraphSelect node edge + , backend ~ PersistEntityBackend node + , backend ~ PersistEntityBackend edge + , PersistQuery 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/Vervis/Model.hs b/src/Vervis/Model.hs index ccab504..20b5df9 100644 --- a/src/Vervis/Model.hs +++ b/src/Vervis/Model.hs @@ -63,8 +63,8 @@ instance PersistEntityGraph Ticket TicketDependency where instance PersistEntityGraphSelect Ticket TicketDependency where type PersistEntityGraphSelector Ticket TicketDependency = ProjectId - selectorParam = ticketProject - selectorField = TicketProject + selectorParam _ = ticketProject + selectorField _ = TicketProject instance PersistEntityGraphNumbered Ticket TicketDependency where numberParam = ticketNumber