From 4eac1ae472a643fe6977362458acc0ff697b1199 Mon Sep 17 00:00:00 2001
From: Portnov <portnov@portnov-laptop.(none)>
Date: Thu, 23 Jul 2009 09:45:52 +0600
Subject: [PATCH] Allow to use SqlValue-s directly in Query

---
 Blog/Blog.hs              |    2 +-
 Framework/API/SQL.hs      |    8 ++++----
 Framework/API/SQLUtils.hs |    4 ++--
 Framework/ORM/SQL.hs      |   27 ++++++++++++++++++++++++---
 Framework/ORM/Types.hs    |   37 ++++++++++++++++++++++++++-----------
 5 files changed, 57 insertions(+), 21 deletions(-)

diff --git a/Blog/Blog.hs b/Blog/Blog.hs
index aa27b36..6e99b5e 100644
--- a/Blog/Blog.hs
+++ b/Blog/Blog.hs
@@ -89,7 +89,7 @@ onepost sid = do
     let pid = read sid
     (form,err) <- create commentModel [toSql pid] url
     post <- getOneObject postModel pid
-    (comments, pagerHtml) <- pager ((table commentModel) `restrict` ("pid" :==: "?")) [toSql pid] commentModel
+    (comments, pagerHtml) <- pager ((table commentModel) `restrict` ("pid" :==: toSql pid)) [] commentModel
     renderToResponseM "onepost.html" [("post", C post),
                                       ("comments", C comments),
                                       ("form", C form),
diff --git a/Framework/API/SQL.hs b/Framework/API/SQL.hs
index edb76ee..91efb05 100644
--- a/Framework/API/SQL.hs
+++ b/Framework/API/SQL.hs
@@ -19,25 +19,25 @@ import Framework.ORM.Models
 queryListSQL :: Query -> [HDBC.SqlValue] -> AController [[HDBC.SqlValue]]
 queryListSQL q params = do
     conn <- asks dbconnection
-    liftIO $ Storage.query conn (sql q) params
+    liftIO $ Storage.query conn (sql q) (getParameters q ++ params)
 
 -- | Same, but strict.
 queryListSQL' :: Query -> [HDBC.SqlValue] -> AController [[HDBC.SqlValue]]
 queryListSQL' q params = do
     conn <- asks dbconnection
-    liftIO $ Storage.query' conn (sql q) params
+    liftIO $ Storage.query' conn (sql q) (getParameters q ++ params)
 
 -- | Same as "query", but gets Query object instead of plain SQL
 querySQL :: Query -> [HDBC.SqlValue] -> Model -> AController [Model]
 querySQL q params model = do
     conn <- asks dbconnection
-    liftIO $ Storage.queryR conn (sql q) params model
+    liftIO $ Storage.queryR conn (sql q) (getParameters q ++ params) model
 
 -- | Same, but strict.
 querySQL' :: Query -> [HDBC.SqlValue] -> Model -> AController [Model]
 querySQL' q params model = do
     conn <- asks dbconnection
-    liftIO $ Storage.queryR' conn (sql q) params model
+    liftIO $ Storage.queryR' conn (sql q) (getParameters q ++ params) model
 
 -- | Select related (children) records for each model in the list. 
 -- This will do one DB query for each list item.
diff --git a/Framework/API/SQLUtils.hs b/Framework/API/SQLUtils.hs
index 76235eb..9718faf 100644
--- a/Framework/API/SQLUtils.hs
+++ b/Framework/API/SQLUtils.hs
@@ -20,7 +20,7 @@ import Framework.API.Storage
 getOneObject :: Model -> Int -> AController Model
 getOneObject model oid = do
     idf <- forceMaybe "Could not find primary key!" $ getPK model
-    objs <- querySQL' ((table model) `restrict` (idf :==: "?")) [HDBC.SqlInt32 $ fromIntegral oid] model
+    objs <- querySQL' ((table model) `restrict` (idf :==: HDBC.toSql oid)) [] model
     assertC $ (length objs)==1
     return $ head objs
 
@@ -71,7 +71,7 @@ deleteModel :: Model         -- ^ Model to delete
             -> AController ()
 deleteModel model oid = do
     send "pre_delete" model
-    queryListSQL' (deleteM model (pk:==:"?")) [HDBC.toSql oid] 
+    queryListSQL' (deleteM model (pk:==:HDBC.toSql oid)) []
     commit
   where
     pk = fromMaybe "id" $ getPK model
diff --git a/Framework/ORM/SQL.hs b/Framework/ORM/SQL.hs
index 91f0c2e..9086509 100644
--- a/Framework/ORM/SQL.hs
+++ b/Framework/ORM/SQL.hs
@@ -1,8 +1,8 @@
 {-# LANGUAGE ExistentialQuantification, FlexibleContexts,NoMonomorphismRestriction, TypeSynonymInstances, PatternGuards #-}
 -- | EDSL for SQL, and SQL generation from Models descriptions
 module Framework.ORM.SQL 
-    (sql,
-     table, select, onlyFields,
+    (sql, getParameters,
+     table, tableR, select, onlyFields,
      sgroup, order,
      restrict,
      limit,
@@ -14,6 +14,8 @@ module Framework.ORM.SQL
 -- import Debug.Trace
 
 import Data.List
+import Data.Maybe
+import Database.HDBC (SqlValue)
 
 import Framework.ORM.Types
 import Framework.ORM.Models
@@ -50,8 +52,27 @@ sql' (UpdateQuery table fields values whre) = "UPDATE "++table++" SET "++eqs++wp
 sql' (DelQuery table whre) = "DELETE FROM "++table++wpart
     where wpart = if whre==NoCondition then "" else " WHERE "++(sqlFragment whre)
 
+getParameters (Query {qWhere=conds}) = params conds
+getParameters (UpdateQuery {uWhere=conds}) = params conds
+getParameters (DelQuery {dWhere=conds}) = params conds
+getParameters _ = []
+
+params (c :&: d) = concatMap params [c,d]
+params (c :|: d) = concatMap params [c,d]
+params (a :==: b) = appendValues a b
+params (a :/=: b) = appendValues a b
+params (a :>: b) = appendValues a b
+params (a :<: b) = appendValues a b
+params NoCondition = []
+
+appendValues :: (Parameter a, Parameter b) => a -> b -> [SqlValue]
+appendValues a b = 
+    let x = asValue a
+        y = asValue b
+    in map fromJust $ filter isJust [x,y]
+
 commas ::  [String] -> String
-commas = concat . intersperse ", "
+commas = intercalate ", "
 
 sqlList ::  (SQLFragment a) => [a] -> [Char]
 sqlList = commas.map sqlFragment
diff --git a/Framework/ORM/Types.hs b/Framework/ORM/Types.hs
index f500651..5166171 100644
--- a/Framework/ORM/Types.hs
+++ b/Framework/ORM/Types.hs
@@ -1,7 +1,7 @@
-{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE ExistentialQuantification, RankNTypes, TypeSynonymInstances #-}
 module Framework.ORM.Types where
 
-import Database.HDBC (SqlValue(..))
+import Database.HDBC (SqlValue(..),toSql)
 import Data.List
 
 import Framework.Types
@@ -42,7 +42,7 @@ data Query = Query                --  SELECT query
     dTable :: String,
     dWhere :: SQLCondition
   }
-  deriving (Eq,Show)
+--   deriving (Eq,Show)
 
 data SQLField = QField String          -- ^ Just a named field
               | QFn String String      -- ^ Some function of field, e.g. count(id)
@@ -53,15 +53,30 @@ type SQLTable = String
 -- | ADT for SQL conditions
 data SQLCondition = 
       NoCondition
-    | Selector :==: Selector
-    | Selector :/=: Selector
-    | Selector :>: Selector
-    | Selector :<: Selector
+    | forall a b. (Parameter a, Parameter b) => a :==: b
+    | forall a b. (Parameter a, Parameter b) => a :/=: b
+    | forall a b. (Parameter a, Parameter b) => a :>: b
+    | forall a b. (Parameter a, Parameter b) => a :<: b
     | SQLCondition :&: SQLCondition
     | SQLCondition :|: SQLCondition
-    deriving (Eq,Show)
 
-type Selector = String
+instance Eq SQLCondition where
+    NoCondition == NoCondition = True
+    _ == _ = False
+
+class Parameter a where
+    asString :: a -> String
+    asValue :: a -> Maybe SqlValue 
+
+instance Parameter String where
+    asString = id
+    asValue x = Nothing
+
+instance Parameter SqlValue where
+    asString = const "?"
+    asValue = Just
+
+type Selector = forall a. Parameter a => a
 
 data SQLOrder = Asceding String | Desceding String
     deriving (Eq,Show)
@@ -81,8 +96,8 @@ instance SQLFragment SQLCondition where
 sqlFPair :: (SQLFragment f) => String -> f -> f -> String
 sqlFPair op x y = (sqlFragment x)++op++(sqlFragment y)
 
-sqlLift ::  [a] -> [a] -> [a] -> [a]
-sqlLift op x y = x++op++y
+sqlLift :: (Parameter a, Parameter a1) => String -> a -> a1 -> String
+sqlLift op x y = (asString x)++op++(asString y)
 
 instance SQLFragment SQLField where
     sqlFragment (QField n) = n
-- 
1.7.2.3