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