module Database.PostgreSQL.Store.Table (
TableDescription (..),
Table (..),
Row (..),
Reference (..),
HasID (..),
TableConstraint (..),
mkTable,
mkCreateQuery
) where
import Control.Monad
import Control.Monad.Trans.Class
import Data.Int
import Data.List
import Data.String
import Data.Typeable
import Language.Haskell.TH
import Database.PostgreSQL.Store.Query
import Database.PostgreSQL.Store.Columns
import Database.PostgreSQL.Store.Result
import Database.PostgreSQL.Store.Errand
data Row a = Row {
rowID :: !Int64,
rowValue :: !a
} deriving (Show, Eq, Ord)
newtype Reference a = Reference Int64
deriving (Show, Eq, Ord)
instance (Table a) => Column (Reference a) where
pack ref =
pack (referenceID ref)
unpack val =
Reference <$> unpack val
describeColumn proxy =
ColumnDescription {
columnTypeName = "bigint references \"" ++ tableName ++ "\" (\"" ++ tableIdentifier ++ "\")",
columnTypeNull = False
}
where
coerceProxy :: Proxy (Reference a) -> Proxy a
coerceProxy _ = Proxy
TableDescription {..} =
describeTable (coerceProxy proxy)
class (DescribableTable a) => Table a where
insert :: a -> Errand (Reference a)
find :: (HasID i) => i a -> Errand (Row a)
update :: (HasID i) => i a -> a -> Errand ()
delete :: (HasID i) => i a -> Errand ()
createQuery :: Proxy a -> Query
tableResultProcessor :: ResultProcessor [Row a]
tableRefResultProcessor :: ResultProcessor [Reference a]
instance (Table a) => Result (Row a) where
resultProcessor = tableResultProcessor
instance (Table a) => Result (Reference a) where
resultProcessor = tableRefResultProcessor
class HasID a where
referenceID :: a b -> Int64
instance HasID Row where
referenceID (Row rid _) = rid
instance HasID Reference where
referenceID (Reference rid) = rid
unqualifyName :: Name -> Name
unqualifyName = mkName . nameBase
insertQueryE :: Name -> [Name] -> Q Exp
insertQueryE name fields =
[e| fromString $(stringE query) |]
where
query =
"INSERT INTO " ++ sanitizeName' name ++ " (" ++
intercalate ", " columns ++
") VALUES (" ++
intercalate ", " values ++
") RETURNING " ++ identField' name
columns =
map (\ nm -> "\"" ++ sanitizeName nm ++ "\"") fields
values =
map (\ idx -> "$" ++ show idx) [1 .. length fields]
findQueryE :: Name -> Q Exp
findQueryE name =
[e| fromString $(stringE query) |]
where
query =
"SELECT * FROM " ++ sanitizeName' name ++
" WHERE " ++ identField' name ++ " = $1 LIMIT 1"
updateQueryE :: Name -> [Name] -> Q Exp
updateQueryE name fields =
[e| fromString $(stringE query) |]
where
query =
"UPDATE " ++ sanitizeName' name ++
" SET " ++ intercalate ", " values ++
" WHERE " ++ identField' name ++ " = $1"
values =
map (\ (nm, idx) -> sanitizeName' nm ++ " = $" ++ show idx)
(zip fields [2 .. length fields + 1])
deleteQueryE :: Name -> Q Exp
deleteQueryE name =
[e| fromString $(stringE query) |]
where
query =
"DELETE FROM " ++ sanitizeName' name ++
" WHERE " ++ identField' name ++ " = $1"
createQueryE :: Name -> [(Name, Type)] -> [TableConstraint] -> Q Exp
createQueryE name fields constraints =
[e| fromString ($(stringE queryBegin) ++
intercalate ", " ($(stringE anchorDescription) :
$fieldList ++
$constraintList) ++
$(stringE queryEnd)) |]
where
queryBegin = "CREATE TABLE IF NOT EXISTS " ++ sanitizeName' name ++ " ("
queryEnd = ")"
anchorDescription =
identField' name ++ " BIGSERIAL NOT NULL PRIMARY KEY"
fieldList =
ListE <$> mapM describeField fields
describeField (fname, ftype) =
[e| $(stringE (sanitizeName' fname)) ++ " " ++
makeColumnDescription (describeColumn (Proxy :: Proxy $(pure ftype))) |]
constraintList =
ListE <$> mapM describeConstraint constraints
describeConstraint cont =
case cont of
Unique names ->
stringE ("UNIQUE (" ++ intercalate ", " (map sanitizeName' names) ++ ")")
ForeignKey names table tableNames ->
stringE ("FOREIGN KEY (" ++ intercalate ", " (map sanitizeName' names) ++
") REFERENCES " ++ sanitizeName' table ++
"(" ++ intercalate ", " (map sanitizeName' tableNames) ++ ")")
packParamsE :: Name -> [Name] -> Q Exp
packParamsE row fields =
ListE <$> mapM extract fields
where
extract name =
[e| pack ($(varE name) $(varE row)) |]
columnInfoE :: Name -> Q Exp
columnInfoE name =
[e| columnInfo (fromString $(stringE (sanitizeName' name))) |]
bindColumnInfoS :: Name -> Q Stmt
bindColumnInfoS name =
BindS (VarP (columnInfoName name)) <$> columnInfoE name
columnInfoName :: Name -> Name
columnInfoName name =
mkName (nameBase name ++ "_info")
unpackColumnE :: Name -> Name -> Q Exp
unpackColumnE row name =
[e| unpackCellValue $(varE row) $(varE (columnInfoName name)) |]
bindColumnS :: Name -> Name -> Q Stmt
bindColumnS row name =
BindS (VarP (unqualifyName name)) <$> unpackColumnE row name
constructRecordE :: Name -> [Name] -> Q Exp
constructRecordE ctor fields =
[e| lift (pure $(pure construction)) |]
where
construction = RecConE ctor (map (\ n -> (n, VarE (unqualifyName n))) fields)
unpackRowE :: Name -> Name -> [Name] -> Q Exp
unpackRowE ctor row fields = do
boundFields <- mapM (bindColumnS row) fields
unboundConstruction <- constructRecordE ctor fields
pure (DoE (boundFields ++ [NoBindS unboundConstruction]))
unpackRowsE :: Name -> Name -> [Name] -> Q Exp
unpackRowsE table ctor fields =
[e| do idNfo <- columnInfo (fromString $(stringE (identField' table)))
foreachRow $ \ row ->
Row <$> unpackCellValue row idNfo
<*> $(unpackRowE ctor 'row fields) |]
tableResultProcessorE :: Name -> Name -> [Name] -> Q Exp
tableResultProcessorE table ctor fields = do
infoBinds <- mapM bindColumnInfoS fields
rowTraversal <- unpackRowsE table ctor fields
pure (DoE (infoBinds ++ [NoBindS rowTraversal]))
tableRefResultProcessorE :: Name -> Q Exp
tableRefResultProcessorE table =
[e| do idNfo <- columnInfo (fromString $(stringE (identField' table)))
foreachRow (\ row -> Reference <$> unpackCellValue row idNfo) |]
implementTableD :: Name -> Name -> [(Name, Type)] -> [TableConstraint] -> Q [Dec]
implementTableD table ctor fields constraints =
[d| instance DescribableTable $(conT table) where
describeTableName _ =
$(stringE (sanitizeName table))
describeTableIdentifier _ =
$(stringE (identField table))
instance Table $(conT table) where
insert row = do
rs <- query Query {
queryStatement = $(insertQueryE table fieldNames),
queryParams = $(packParamsE 'row fieldNames)
}
case rs of
(ref : _) -> pure ref
_ -> raiseErrandError UnexpectedEmptyResult
find ref = do
rs <- query Query {
queryStatement = $(findQueryE table),
queryParams = [pack (referenceID ref)]
}
case rs of
(row : _) -> pure row
_ -> raiseErrandError UnexpectedEmptyResult
update ref row =
query_ Query {
queryStatement = $(updateQueryE table fieldNames),
queryParams = pack (referenceID ref) : $(packParamsE 'row fieldNames)
}
delete ref =
query_ Query {
queryStatement = $(deleteQueryE table),
queryParams = [pack (referenceID ref)]
}
createQuery _ =
Query {
queryStatement = $(createQueryE table fields constraints),
queryParams = []
}
tableResultProcessor =
$(tableResultProcessorE table ctor fieldNames)
tableRefResultProcessor =
$(tableRefResultProcessorE table) |]
where
fieldNames = map fst fields
validateFields :: [(Name, Type)] -> Q ()
validateFields fields =
forM_ fields $ \ (name, typ) -> do
ii <- isInstance ''Column [typ]
unless ii $
fail ("\ESC[35m" ++ show name ++ "\ESC[0m's type does not have an instance of \ESC[34mColumn\ESC[0m")
data TableConstraint
= Unique [Name]
| ForeignKey [Name] Name [Name]
deriving (Show, Eq, Ord)
mkTable :: Name -> [TableConstraint] -> Q [Dec]
mkTable name constraints = do
info <- reify name
case info of
TyConI dec ->
case dec of
DataD [] _ [] [RecC ctor records@(_ : _)] _ -> do
let fields = map (\ (fn, _, ft) -> (fn, ft)) records
validateFields fields
implementTableD name ctor fields constraints
DataD (_ : _) _ _ _ _ ->
fail ("\ESC[34m" ++ show name ++ "\ESC[0m has a context")
DataD _ _ (_ : _) _ _ ->
fail ("\ESC[34m" ++ show name ++ "\ESC[0m has one or more type variables")
DataD _ _ _ [] _ ->
fail ("\ESC[34m" ++ show name ++ "\ESC[0m does not have a constructor")
DataD _ _ _ (_ : _ : _) _ ->
fail ("\ESC[34m" ++ show name ++ "\ESC[0m has more than one constructor")
DataD _ _ _ [RecC _ []] _ ->
fail ("\ESC[34m" ++ show name ++ "\ESC[0m has an empty record constructor")
DataD _ _ _ [_] _ ->
fail ("\ESC[34m" ++ show name ++ "\ESC[0m does not have a record constructor")
_ -> fail ("\ESC[34m" ++ show name ++ "\ESC[0m is not an eligible data type")
_ -> fail ("\ESC[34m" ++ show name ++ "\ESC[0m is not a type constructor")
isType :: Name -> Q Bool
isType name = do
info <- reify name
pure $ case info of
TyConI _ -> True
_ -> False
mkCreateQuery :: Name -> Q Exp
mkCreateQuery name = do
it <- isType name
unless it (fail "Given name does not refer to a type.")
[e| createQuery (Proxy :: Proxy $(pure (ConT name))) |]