module Database.PostgreSQL.Models
( FromParams(..), Param
, PostgreSQLModel(..)
, HasMany(..)
, TableName(..), fromTableName
, fromString, IsString
) where
import Data.List (intersperse)
import Data.String
import Database.PostgreSQL.Simple
import Database.PostgreSQL.Simple.ToField
import Database.PostgreSQL.Simple.ToRow
import Database.PostgreSQL.Simple.FromField
import Network.Wai.Parse
class FromParams p where
fromParams :: [Param] -> Maybe p
instance (FromParams a, FromParams b) => FromParams (a, b) where
fromParams params = do
a <- fromParams params
b <- fromParams params
return (a, b)
newtype TableName p = TableName String deriving (Show, Eq)
fromTableName :: TableName p -> String
fromTableName (TableName s) = s
class (FromRow p, ToRow p, ToField (PrimaryKey p), FromField (PrimaryKey p))
=> PostgreSQLModel p where
type PrimaryKey p :: *
primaryKey :: p -> Maybe (PrimaryKey p)
tableName :: p -> TableName p
columns :: TableName p -> [String]
primaryKeyName :: TableName p -> String
primaryKeyName _ = "id"
columns_ :: TableName p -> [String]
columns_ tName = (primaryKeyName tName):(columns tName)
orderBy :: TableName p -> Maybe String
orderBy _ = Nothing
insert :: p -> Connection -> IO (PrimaryKey p)
insert model conn = do
query conn template fields >>= return . head . head
where template = fromString $ concat
[ "insert into "
, fromTableName tName
, " (" ++ cols ++ ")"
, " VALUES (" ++ qs ++ ") RETURNING "
, primaryKeyName tName]
tName = tableName model
qs = concat $ intersperse ", " $ map (const "?") $ colNames
cols = concat $ intersperse ", " $ colNames
colNameFields = case primaryKey model of
Nothing -> (columns tName, toRow model)
Just pkey -> ( columns_ tName
, (toField pkey):(toRow model))
(_, fields) = colNameFields
(colNames, _) = colNameFields
upsert :: p -> Connection -> IO (PrimaryKey p)
upsert model conn = do
case primaryKey model of
Nothing -> insert model conn
Just pkey -> do
execute conn template $ toRow model ++ [toField pkey]
return pkey
where template = fromString $ concat
["update "
, fromTableName tName
, " SET "
, cols, " where ", primaryKeyName tName
, " = ?"]
tName = tableName model
cols = concat $ intersperse ", " $ map (++ " =?") (columns tName)
find :: TableName p -> PrimaryKey p -> Connection -> IO (Maybe p)
find tn = findFirst tn (primaryKeyName tn)
findFirst :: ToField f
=> TableName p
-> String
-> f
-> Connection -> IO (Maybe p)
findFirst tName col val conn = do
models <- query conn template (Only val)
case models of
(model:_) -> return $ Just model
[] -> return Nothing
where template = fromString $ concat
["select ", cols, " from "
, fromTableName tName
, " where "
, col
, " = ?"
, maybe "" (" order by " ++) $ orderBy tName
, " limit 1"]
cols = concat $ intersperse ", " $ columns_ tName
findAll :: TableName p -> Connection -> IO [p]
findAll tName conn = query_ conn template
where template = fromString $ concat
[ "select ", cols, " from "
, fromTableName tName
, maybe "" (" order by " ++) $ orderBy tName]
cols = concat $ intersperse ", " $ columns_ tName
findAllBy :: ToField f
=> TableName p
-> String
-> f
-> Connection -> IO [p]
findAllBy tName col val conn = query conn template (Only val)
where template = fromString $ concat
[ "select ", cols, " from "
, fromTableName tName
, " where ", col, " = ?"
, maybe "" (" order by " ++) $ orderBy tName]
cols = concat $ intersperse ", " $ columns_ tName
class (PostgreSQLModel parent, PostgreSQLModel child) =>
HasMany parent child where
foreignKey :: TableName parent -> TableName child -> String
foreignKey tName _ = fromTableName tName ++ "_" ++ (primaryKeyName tName)
childrenOf :: parent -> TableName child -> Connection -> IO [child]
childrenOf parent ctName conn = query conn template (Only $ primaryKey parent)
where template = fromString $ concat $
[ "select ", childColumns, " from "
, fromTableName ctName
, " where "
, foreignKey ptName ctName
, " = ?"
, maybe "" (" order by " ++) $ orderBy ctName]
ptName = tableName parent
childColumns = concat $ intersperse ", " $ columns_ ctName
childOf :: parent -> TableName child
-> PrimaryKey child -> Connection -> IO (Maybe child)
childOf parent ctName v = childOfBy parent ctName (primaryKeyName ctName) v
childOfBy :: ToField v
=> parent
-> TableName child
-> String
-> v
-> Connection -> IO (Maybe child)
childOfBy parent ctName col pkeyc conn = do
mchildren <- query conn template (primaryKey parent, pkeyc)
case mchildren of
[] -> return Nothing
(c:_) -> return $ Just c
where template = fromString $ concat $
[ "select ", childColumns, " from "
, fromTableName ctName
, " where "
, foreignKey ptName ctName, " = ?"
, " and ", col, " = ?"
, maybe "" (" order by " ++) $ orderBy ctName
, " limit 1"]
ptName = tableName parent
childColumns = concat $ intersperse ", " $ columns_ ctName
childrenOfBy :: ToField f
=> parent
-> TableName child
-> String
-> f
-> Connection -> IO [child]
childrenOfBy parent ctName col val conn =
query conn template (primaryKey parent, val)
where template = fromString $ concat $
[ "select ", childColumns, " from "
, fromTableName ctName
, " where "
, foreignKey ptName ctName
, " = ? and ", col, " = ?"
, maybe "" (" order by " ++) $ orderBy ctName]
ptName = tableName parent
childColumns = concat $ intersperse ", " $ columns_ ctName
insertFor :: parent -> child -> Connection -> IO (PrimaryKey child)
insertFor parent chld conn = do
query conn template (fields ++ [toField $ primaryKey parent])
>>= return . head . head
where template = fromString $ concat
[ "insert into "
, fromTableName ctName
, " (", cols, ", ", foreignKey ptName ctName, ")"
, " VALUES (", qs, ", ?) "
, " RETURNING "
, primaryKeyName ctName]
ctName = tableName chld
ptName = tableName parent
qs = concat $ intersperse ", " $ map (const "?") $ colNames
cols = concat $ intersperse ", " $ colNames
colNameFields = case primaryKey chld of
Nothing -> (columns ctName, toRow chld)
Just pkey -> ( columns_ ctName
, (toField pkey):(toRow chld))
(_, fields) = colNameFields
(colNames, _) = colNameFields