From 7d6ef47e0508b4da98803a5814b2ec802debd61a Mon Sep 17 00:00:00 2001
From: fr33domlover <fr33domlover@rel4tion.org>
Date: Wed, 3 Aug 2016 21:26:39 +0000
Subject: [PATCH] DB actions for selecting nodes and edges of single graph

---
 .../Persist/Local/Class/PersistEntityGraph.hs | 12 ++--
 src/Database/Persist/Local/Sql.hs             | 59 +++++++++++++++++++
 src/Vervis/Model.hs                           |  4 +-
 3 files changed, 69 insertions(+), 6 deletions(-)

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