module Database.Groundhog.Postgresql
( withPostgresqlPool
, withPostgresqlConn
, runPostgresqlPool
, runPostgresqlConn
, Postgresql
, module Database.Groundhog
) where
import Database.Groundhog
import Database.Groundhog.Core
import Database.Groundhog.Generic
import Database.Groundhog.Generic.Migration hiding (MigrationPack(..))
import qualified Database.Groundhog.Generic.Migration as GM
import Database.Groundhog.Generic.Sql.String
import qualified Database.Groundhog.Generic.PersistBackendHelpers as H
import qualified Database.PostgreSQL.Simple as PG
import qualified Database.PostgreSQL.Simple.BuiltinTypes as PG
import qualified Database.PostgreSQL.Simple.Internal as PG
import qualified Database.PostgreSQL.Simple.ToField as PGTF
import qualified Database.PostgreSQL.Simple.FromField as PGFF
import qualified Database.PostgreSQL.Simple.Types as PG
import Database.PostgreSQL.Simple.Ok (Ok (..))
import qualified Database.PostgreSQL.LibPQ as LibPQ
import Control.Arrow ((***))
import Control.Exception (throw)
import Control.Monad (forM, liftM, liftM2)
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Trans.Control (MonadBaseControl)
import Control.Monad.Trans.Reader (ask)
import Data.ByteString.Char8 (ByteString, pack, unpack, copy)
import Data.Either (partitionEithers)
import Data.Function (on)
import Data.Int (Int64)
import Data.IORef
import Data.List (groupBy, intercalate)
import Data.Monoid
import Data.Conduit.Pool
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Data.Time.LocalTime (localTimeToUTC, utc)
import System.IO.Unsafe (unsafePerformIO)
newtype Postgresql = Postgresql PG.Connection
instance DbDescriptor Postgresql where
type AutoKeyType Postgresql = Int64
instance (MonadBaseControl IO m, MonadIO m) => PersistBackend (DbPersist Postgresql m) where
type PhantomDb (DbPersist Postgresql m) = Postgresql
insert v = insert' v
insertBy u v = H.insertBy escapeS queryRawTyped' u v
insertByAll v = H.insertByAll escapeS queryRawTyped' v
replace k v = H.replace escapeS queryRawTyped' executeRaw' insertIntoConstructorTable k v
select options = H.select escapeS queryRawTyped' "" renderCond' options
selectAll = H.selectAll escapeS queryRawTyped'
get k = H.get escapeS queryRawTyped' k
getBy k = H.getBy escapeS queryRawTyped' k
update upds cond = H.update escapeS executeRaw' renderCond' upds cond
delete cond = H.delete escapeS executeRaw' renderCond' cond
deleteByKey k = H.deleteByKey escapeS executeRaw' k
count cond = H.count escapeS queryRawTyped' renderCond' cond
countAll fakeV = H.countAll escapeS queryRawTyped' fakeV
project p options = H.project escapeS queryRawTyped' "" renderCond' p options
migrate fakeV = migrate' fakeV
executeRaw _ query ps = executeRaw' (fromString query) ps
queryRaw _ query ps f = queryRaw' (fromString query) ps f
insertList l = insertList' l
getList k = getList' k
withPostgresqlPool :: (MonadBaseControl IO m, MonadIO m)
=> String
-> Int
-> (Pool Postgresql -> m a)
-> m a
withPostgresqlPool s connCount f = liftIO (createPool (open' s) close' 1 20 connCount) >>= f
withPostgresqlConn :: (MonadBaseControl IO m, MonadIO m)
=> String
-> (Postgresql -> m a)
-> m a
withPostgresqlConn s = bracket (liftIO $ open' s) (liftIO . close')
runPostgresqlPool :: (MonadBaseControl IO m, MonadIO m) => DbPersist Postgresql m a -> Pool Postgresql -> m a
runPostgresqlPool f pconn = withResource pconn $ runPostgresqlConn f
runPostgresqlConn :: (MonadBaseControl IO m, MonadIO m) => DbPersist Postgresql m a -> Postgresql -> m a
runPostgresqlConn f conn@(Postgresql c) = do
liftIO $ PG.begin c
x <- onException (runDbPersist f conn) (liftIO $ PG.rollback c)
liftIO $ PG.commit c
return x
open' :: String -> IO Postgresql
open' s = do
conn <- PG.connectPostgreSQL $ pack s
PG.execute_ conn $ getStatement "SET client_min_messages TO WARNING"
return $ Postgresql conn
close' :: Postgresql -> IO ()
close' (Postgresql conn) = PG.close conn
insert' :: (PersistEntity v, MonadBaseControl IO m, MonadIO m) => v -> DbPersist Postgresql m (AutoKey v)
insert' v = do
vals <- toEntityPersistValues' v
let e = entityDef v
let name = persistName v
let constructorNum = fromPrimitivePersistValue proxy (head vals)
liftM fst $ if isSimple (constructors e)
then do
let constr = head $ constructors e
let query = insertIntoConstructorTable False name constr
case constrAutoKeyName constr of
Nothing -> executeRaw' query (tail vals) >> pureFromPersistValue []
Just _ -> do
x <- queryRaw' query (tail vals) id
case x of
Just xs -> pureFromPersistValue xs
Nothing -> pureFromPersistValue []
else do
let constr = constructors e !! constructorNum
let cName = name ++ [delim] ++ constrName constr
let query = "INSERT INTO " <> escapeS (fromString name) <> "(discr)VALUES(?)RETURNING(id)"
rowid <- queryRaw' query (take 1 vals) getKey
let cQuery = insertIntoConstructorTable True cName constr
executeRaw' cQuery $ rowid:(tail vals)
pureFromPersistValue [rowid]
insertIntoConstructorTable :: Bool -> String -> ConstructorDef -> StringS
insertIntoConstructorTable withId tName c = "INSERT INTO " <> escapeS (fromString tName) <> "(" <> fieldNames <> ")VALUES(" <> placeholders <> ")" <> returning where
(fields, returning) = case constrAutoKeyName c of
Just idName | withId -> ((idName, dbType (0 :: Int64)):constrParams c, mempty)
| otherwise -> (constrParams c, "RETURNING(" <> escapeS (fromString idName) <> ")")
_ -> (constrParams c, mempty)
fieldNames = renderFields escapeS fields
placeholders = renderFields (const $ fromChar '?') fields
insertList' :: forall m a.(MonadBaseControl IO m, MonadIO m, PersistField a) => [a] -> DbPersist Postgresql m Int64
insertList' (l :: [a]) = do
let mainName = "List" <> delim' <> delim' <> fromString (persistName (undefined :: a))
k <- queryRaw' ("INSERT INTO " <> escapeS mainName <> " DEFAULT VALUES RETURNING(id)") [] getKey
let valuesName = mainName <> delim' <> "values"
let fields = [("ord", dbType (0 :: Int)), ("value", dbType (undefined :: a))]
let query = "INSERT INTO " <> escapeS valuesName <> "(id," <> renderFields escapeS fields <> ")VALUES(?," <> renderFields (const $ fromChar '?') fields <> ")"
let go :: Int -> [a] -> DbPersist Postgresql m ()
go n (x:xs) = do
x' <- toPersistValues x
executeRaw' query $ (k:) . (toPrimitivePersistValue proxy n:) . x' $ []
go (n + 1) xs
go _ [] = return ()
go 0 l
return $ fromPrimitivePersistValue proxy k
getList' :: forall m a.(MonadBaseControl IO m, MonadIO m, PersistField a) => Int64 -> DbPersist Postgresql m [a]
getList' k = do
let mainName = "List" <> delim' <> delim' <> fromString (persistName (undefined :: a))
let valuesName = mainName <> delim' <> "values"
let value = ("value", dbType (undefined :: a))
let query = "SELECT " <> renderFields escapeS [value] <> " FROM " <> escapeS valuesName <> " WHERE id=? ORDER BY ord"
queryRaw' query [toPrimitivePersistValue proxy k] $ mapAllRows (liftM fst . fromPersistValues)
getKey :: MonadIO m => RowPopper (DbPersist Postgresql m) -> DbPersist Postgresql m PersistValue
getKey pop = pop >>= \(Just [k]) -> return k
executeRaw' :: MonadIO m => StringS -> [PersistValue] -> DbPersist Postgresql m ()
executeRaw' query vals = do
Postgresql conn <- DbPersist ask
let stmt = getStatement query
liftIO $ do
_ <- PG.execute conn stmt (map P vals)
return ()
renderCond' :: (PersistEntity v, Constructor c) => Cond v c -> Maybe (RenderS StringS)
renderCond' = renderCond proxy escapeS renderEquals renderNotEquals where
renderEquals a b = a <> " IS NOT DISTINCT FROM " <> b
renderNotEquals a b = a <> " IS DISTINCT FROM " <> b
escapeS :: StringS -> StringS
escapeS a = let q = fromChar '"' in q <> a <> q
delim' :: StringS
delim' = fromChar delim
toEntityPersistValues' :: (MonadBaseControl IO m, MonadIO m, PersistEntity v) => v -> DbPersist Postgresql m [PersistValue]
toEntityPersistValues' = liftM ($ []) . toEntityPersistValues
migrate' :: (PersistEntity v, MonadBaseControl IO m, MonadIO m) => v -> Migration (DbPersist Postgresql m)
migrate' = migrateRecursively (migrateEntity migrationPack) (migrateList migrationPack)
migrationPack :: (MonadBaseControl IO m, MonadIO m) => GM.MigrationPack (DbPersist Postgresql m)
migrationPack = GM.MigrationPack
compareTypes
compareRefs
compareUniqs
checkTable
migTriggerOnDelete
migTriggerOnUpdate
GM.defaultMigConstr
escape
"SERIAL PRIMARY KEY UNIQUE"
"INT8"
mainTableId
defaultPriority
(\uniques refs -> ([], map AddUnique uniques ++ map AddReference refs))
showColumn
showAlterDb
showColumn :: Column -> String
showColumn (Column n nu t def) = concat
[ escape n
, " "
, showSqlType t
, " "
, if nu then "NULL" else "NOT NULL"
, case def of
Nothing -> ""
Just s -> " DEFAULT " ++ s
]
checkFunction :: (MonadBaseControl IO m, MonadIO m) => String -> DbPersist Postgresql m (Maybe String)
checkFunction name = do
x <- queryRaw' "SELECT p.prosrc FROM pg_catalog.pg_namespace n INNER JOIN pg_catalog.pg_proc p ON p.pronamespace = n.oid WHERE n.nspname = 'public' AND p.proname = ?" [toPrimitivePersistValue proxy name] id
case x of
Nothing -> return Nothing
Just src -> return (fst $ fromPurePersistValues proxy src)
checkTrigger :: (MonadBaseControl IO m, MonadIO m) => String -> DbPersist Postgresql m (Maybe String)
checkTrigger name = do
x <- queryRaw' "SELECT action_statement FROM information_schema.triggers WHERE trigger_name = ?" [toPrimitivePersistValue proxy name] id
case x of
Nothing -> return Nothing
Just src -> return (fst $ fromPurePersistValues proxy src)
migTriggerOnDelete :: (MonadBaseControl IO m, MonadIO m) => String -> [(String, String)] -> DbPersist Postgresql m (Bool, [AlterDB])
migTriggerOnDelete name deletes = do
let funcName = name
let trigName = name
func <- checkFunction funcName
trig <- checkTrigger trigName
let funcBody = "BEGIN " ++ concatMap snd deletes ++ "RETURN NEW;END;"
addFunction = CreateOrReplaceFunction $ "CREATE OR REPLACE FUNCTION " ++ escape funcName ++ "() RETURNS trigger AS $$" ++ funcBody ++ "$$ LANGUAGE plpgsql"
funcMig = case func of
Nothing | null deletes -> []
Nothing -> [addFunction]
Just body -> if null deletes
then [DropFunction funcName]
else if body == funcBody
then []
else [DropFunction funcName, addFunction]
trigBody = "EXECUTE PROCEDURE " ++ escape funcName ++ "()"
addTrigger = AddTriggerOnDelete trigName name trigBody
(trigExisted, trigMig) = case trig of
Nothing | null deletes -> (False, [])
Nothing -> (False, [addTrigger])
Just body -> (True, if null deletes
then [DropTrigger trigName name]
else if body == trigBody
then []
else [DropTrigger trigName name, addTrigger])
return (trigExisted, funcMig ++ trigMig)
migTriggerOnUpdate :: (MonadBaseControl IO m, MonadIO m) => String -> String -> String -> DbPersist Postgresql m (Bool, [AlterDB])
migTriggerOnUpdate name fieldName del = do
let funcName = name ++ delim : fieldName
let trigName = name ++ delim : fieldName
func <- checkFunction funcName
trig <- checkTrigger trigName
let funcBody = "BEGIN " ++ del ++ "RETURN NEW;END;"
addFunction = CreateOrReplaceFunction $ "CREATE OR REPLACE FUNCTION " ++ escape funcName ++ "() RETURNS trigger AS $$" ++ funcBody ++ "$$ LANGUAGE plpgsql"
funcMig = case func of
Nothing -> [addFunction]
Just body -> if body == funcBody
then []
else [DropFunction funcName, addFunction]
trigBody = "EXECUTE PROCEDURE " ++ escape funcName ++ "()"
addTrigger = AddTriggerOnUpdate trigName name fieldName trigBody
(trigExisted, trigMig) = case trig of
Nothing -> (False, [addTrigger])
Just body -> (True, if body == trigBody
then []
else [DropTrigger trigName name, addTrigger])
return (trigExisted, funcMig ++ trigMig)
checkTable :: (MonadBaseControl IO m, MonadIO m) => String -> DbPersist Postgresql m (Maybe (Either [String] TableInfo))
checkTable name = do
table <- queryRaw' "SELECT * FROM information_schema.tables WHERE table_name=?" [toPrimitivePersistValue proxy name] id
case table of
Just _ -> do
cols <- queryRaw' "SELECT c.column_name, c.is_nullable, c.udt_name, c.character_maximum_length, c.numeric_precision, c.numeric_scale, c.datetime_precision, c.interval_type, c.column_default FROM information_schema.columns c WHERE c.table_name=? AND c.column_name NOT IN (SELECT c.column_name FROM information_schema.table_constraints tc INNER JOIN information_schema.constraint_column_usage u ON tc.constraint_catalog = u.constraint_catalog AND tc.constraint_schema=u.constraint_schema AND tc.constraint_name=u.constraint_name INNER JOIN information_schema.columns c ON u.table_catalog=c.table_catalog AND u.table_schema=c.table_schema AND u.table_name=c.table_name AND u.column_name=c.column_name WHERE tc.constraint_type='PRIMARY KEY' AND tc.table_name=?) ORDER BY c.ordinal_position" [toPrimitivePersistValue proxy name, toPrimitivePersistValue proxy name] (mapAllRows $ return . getColumn name . fst . fromPurePersistValues proxy)
let (col_errs, cols') = partitionEithers cols
uniqConstraints <- queryRaw' "SELECT u.constraint_name, u.column_name FROM information_schema.table_constraints tc INNER JOIN information_schema.constraint_column_usage u ON tc.constraint_catalog=u.constraint_catalog AND tc.constraint_schema=u.constraint_schema AND tc.constraint_name=u.constraint_name WHERE u.table_name=? AND tc.constraint_type='UNIQUE' ORDER BY u.constraint_name, u.column_name" [toPrimitivePersistValue proxy name] (mapAllRows $ return . fst . fromPurePersistValues proxy)
uniqIndexes <- queryRaw' "SELECT ic.relname, a.attname FROM pg_catalog.pg_attribute a INNER JOIN pg_catalog.pg_class ic ON ic.oid = a.attrelid INNER JOIN pg_catalog.pg_index i ON i.indexrelid = ic.oid INNER JOIN pg_catalog.pg_class tc ON i.indrelid = tc.oid WHERE tc.relname = ? AND a.attnum > 0 AND NOT a.attisdropped AND ic.oid NOT IN (SELECT conindid FROM pg_catalog.pg_constraint) AND NOT i.indisprimary AND i.indisunique ORDER BY ic.relname, a.attnum" [toPrimitivePersistValue proxy name] (mapAllRows $ return . fst . fromPurePersistValues proxy)
let mkUniqs typ = map (\us -> UniqueDef' (fst $ head us) typ (map snd us)) . groupBy ((==) `on` fst)
let uniqs = mkUniqs UniqueConstraint uniqConstraints ++ mkUniqs UniqueIndex uniqIndexes
references <- checkTableReferences name
primaryKeyResult <- checkPrimaryKey name
let (primaryKey, uniqs') = case primaryKeyResult of
(Left primaryKeyName) -> (primaryKeyName, uniqs)
(Right u) -> (Nothing, u:uniqs)
return $ Just $ case col_errs of
[] -> Right $ TableInfo primaryKey cols' uniqs' references
errs -> Left errs
Nothing -> return Nothing
checkPrimaryKey :: (MonadBaseControl IO m, MonadIO m) => String -> DbPersist Postgresql m (Either (Maybe String) UniqueDef')
checkPrimaryKey name = do
uniqRows <- queryRaw' "SELECT u.constraint_name, u.column_name FROM information_schema.table_constraints tc INNER JOIN information_schema.constraint_column_usage u ON tc.constraint_catalog = u.constraint_catalog AND tc.constraint_schema=u.constraint_schema AND tc.constraint_name=u.constraint_name WHERE tc.constraint_type='PRIMARY KEY' AND tc.table_name=?" [toPrimitivePersistValue proxy name] (mapAllRows $ return . fst . fromPurePersistValues proxy)
let mkUniq us = UniqueDef' (fst $ head us) UniqueConstraint (map snd us)
return $ case uniqRows of
[] -> Left Nothing
[(_, primaryKeyName)] -> Left $ Just primaryKeyName
us -> Right $ mkUniq us
getColumn :: String -> (String, String, String, (Maybe Int, Maybe Int, Maybe Int, Maybe Int, Maybe String), Maybe String) -> Either String Column
getColumn _ (column_name, is_nullable, udt_name, modifiers, d) = Right $ Column column_name (is_nullable == "YES") t d where
t = readSqlType udt_name modifiers
checkTableReferences :: (MonadBaseControl IO m, MonadIO m) => String -> DbPersist Postgresql m [(Maybe String, Reference)]
checkTableReferences tableName = do
let sql = "SELECT c.conname, c.foreign_table || '', a_child.attname AS child, a_parent.attname AS parent FROM (SELECT r.confrelid::regclass AS foreign_table, r.conrelid, r.confrelid, unnest(r.conkey) AS conkey, unnest(r.confkey) AS confkey, r.conname FROM pg_catalog.pg_constraint r WHERE r.conrelid = ?::regclass AND r.contype = 'f') AS c INNER JOIN pg_attribute a_parent ON a_parent.attnum = c.confkey AND a_parent.attrelid = c.confrelid INNER JOIN pg_attribute a_child ON a_child.attnum = c.conkey AND a_child.attrelid = c.conrelid ORDER BY c.conname"
x <- queryRaw' sql [toPrimitivePersistValue proxy $ escape tableName] $ mapAllRows (return . fst . fromPurePersistValues proxy)
let mkReference xs = (Just refName, (parentTable, map (snd . snd) xs)) where
(refName, (parentTable, _)) = head xs
references = map mkReference $ groupBy ((==) `on` fst) x
return references
showAlterDb :: AlterDB -> SingleMigration
showAlterDb (AddTable s) = Right [(False, defaultPriority, s)]
showAlterDb (AlterTable t _ _ _ alts) = Right $ map (showAlterTable t) alts
showAlterDb (DropTrigger trigName tName) = Right [(False, triggerPriority, "DROP TRIGGER " ++ escape trigName ++ " ON " ++ escape tName)]
showAlterDb (AddTriggerOnDelete trigName tName body) = Right [(False, triggerPriority, "CREATE TRIGGER " ++ escape trigName ++ " AFTER DELETE ON " ++ escape tName ++ " FOR EACH ROW " ++ body)]
showAlterDb (AddTriggerOnUpdate trigName tName fName body) = Right [(False, triggerPriority, "CREATE TRIGGER " ++ escape trigName ++ " AFTER UPDATE OF " ++ escape fName ++ " ON " ++ escape tName ++ " FOR EACH ROW " ++ body)]
showAlterDb (CreateOrReplaceFunction s) = Right [(False, functionPriority, s)]
showAlterDb (DropFunction funcName) = Right [(False, functionPriority, "DROP FUNCTION " ++ escape funcName ++ "()")]
showAlterTable :: String -> AlterTable -> (Bool, Int, String)
showAlterTable table (AlterColumn alt) = showAlterColumn table alt
showAlterTable table (AddUnique (UniqueDef' uName UniqueConstraint cols)) = (False, defaultPriority, concat
[ "ALTER TABLE "
, escape table
, " ADD CONSTRAINT "
, escape uName
, " UNIQUE("
, intercalate "," $ map escape cols
, ")"
])
showAlterTable table (AddUnique (UniqueDef' uName UniqueIndex cols)) = (False, defaultPriority, concat
[ "CREATE UNIQUE INDEX "
, escape uName
, " ON "
, escape table
, "("
, intercalate "," $ map escape cols
, ")"
])
showAlterTable table (DropConstraint uName) = (False, defaultPriority, concat
[ "ALTER TABLE "
, escape table
, " DROP CONSTRAINT "
, escape uName
])
showAlterTable _ (DropIndex uName) = (False, defaultPriority, concat
[ "DROP INDEX "
, escape uName
])
showAlterTable table (AddReference (tName, columns)) = (False, referencePriority, concat
[ "ALTER TABLE "
, escape table
, " ADD FOREIGN KEY("
, our
, ") REFERENCES "
, escape tName
, "("
, foreign
, ")"
]) where
(our, foreign) = f *** f $ unzip columns
f = intercalate ", " . map escape
showAlterTable table (DropReference name) = (False, defaultPriority,
"ALTER TABLE " ++ escape table ++ " DROP CONSTRAINT " ++ name)
showAlterColumn :: String -> AlterColumn' -> (Bool, Int, String)
showAlterColumn table (n, Type t) = (False, defaultPriority, concat
[ "ALTER TABLE "
, escape table
, " ALTER COLUMN "
, escape n
, " TYPE "
, showSqlType t
])
showAlterColumn table (n, IsNull) = (False, defaultPriority, concat
[ "ALTER TABLE "
, escape table
, " ALTER COLUMN "
, escape n
, " DROP NOT NULL"
])
showAlterColumn table (n, NotNull) = (False, defaultPriority, concat
[ "ALTER TABLE "
, escape table
, " ALTER COLUMN "
, escape n
, " SET NOT NULL"
])
showAlterColumn table (_, Add col) = (False, defaultPriority, concat
[ "ALTER TABLE "
, escape table
, " ADD COLUMN "
, showColumn col
])
showAlterColumn table (n, Drop) = (True, defaultPriority, concat
[ "ALTER TABLE "
, escape table
, " DROP COLUMN "
, escape n
])
showAlterColumn table (n, AddPrimaryKey) = (False, defaultPriority, concat
[ "ALTER TABLE "
, escape table
, " ADD COLUMN "
, escape n
, " SERIAL PRIMARY KEY UNIQUE"
])
showAlterColumn table (n, Default s) = (False, defaultPriority, concat
[ "ALTER TABLE "
, escape table
, " ALTER COLUMN "
, escape n
, " SET DEFAULT "
, s
])
showAlterColumn table (n, NoDefault) = (False, defaultPriority, concat
[ "ALTER TABLE "
, escape table
, " ALTER COLUMN "
, escape n
, " DROP DEFAULT"
])
showAlterColumn table (n, UpdateValue s) = (False, defaultPriority, concat
[ "UPDATE "
, escape table
, " SET "
, escape n
, "="
, s
, " WHERE "
, escape n
, " IS NULL"
])
readSqlType :: String -> (Maybe Int, Maybe Int, Maybe Int, Maybe Int, Maybe String) -> DbType
readSqlType typ (character_maximum_length, numeric_precision, numeric_scale, datetime_precision, _) = (case typ of
"int4" -> DbInt32
"int8" -> DbInt64
"varchar" -> maybe DbString (DbOther . ("varchar"++) . wrap . show) character_maximum_length
"numeric" -> DbOther $ "numeric" ++ maybe "" wrap attrs where
attrs = liftM2 (\a b -> if b == 0 then show a else show a ++ ", " ++ show b) numeric_precision numeric_scale
"date" -> DbDay
"bool" -> DbBool
"time" -> mkDate DbTime "time"
"timestamp" -> mkDate DbDayTime "timestamp"
"timestamptz" -> mkDate DbDayTimeZoned "timestamptz"
"float4" -> DbReal
"float8" -> DbReal
"bytea" -> DbBlob
a -> DbOther a) where
wrap x = "(" ++ x ++ ")"
mkDate t name = maybe t (DbOther . (name++) . wrap . show) datetime_precision'
defDateTimePrec = 6
datetime_precision' = datetime_precision >>= \p -> if p == defDateTimePrec then Nothing else Just p
showSqlType :: DbType -> String
showSqlType DbString = "VARCHAR"
showSqlType DbInt32 = "INT4"
showSqlType DbInt64 = "INT8"
showSqlType DbReal = "DOUBLE PRECISION"
showSqlType DbBool = "BOOLEAN"
showSqlType DbDay = "DATE"
showSqlType DbTime = "TIME"
showSqlType DbDayTime = "TIMESTAMP"
showSqlType DbDayTimeZoned = "TIMESTAMP WITH TIME ZONE"
showSqlType DbBlob = "BYTEA"
showSqlType (DbOther name) = name
showSqlType (DbMaybe t) = showSqlType t
showSqlType (DbList _ _) = showSqlType DbInt64
showSqlType (DbEntity Nothing _) = showSqlType DbInt64
showSqlType t = error $ "showSqlType: DbType does not have corresponding database type: " ++ show t
compareUniqs :: UniqueDef' -> UniqueDef' -> Bool
compareUniqs (UniqueDef' name1 typ1 cols1) (UniqueDef' name2 typ2 cols2) = name1 == name2 && typ1 == typ2 && haveSameElems (==) cols1 cols2
compareRefs :: (Maybe String, Reference) -> (Maybe String, Reference) -> Bool
compareRefs (_, (tbl1, pairs1)) (_, (tbl2, pairs2)) = unescape tbl1 == unescape tbl2 && haveSameElems (==) pairs1 pairs2 where
unescape name = if head name == '"' && last name == '"' then tail $ init name else name
compareTypes :: DbType -> DbType -> Bool
compareTypes type1 type2 = showSqlType (simplifyType type1) == showSqlType (simplifyType type2)
simplifyType :: DbType -> DbType
simplifyType (DbEntity Nothing _) = DbInt64
simplifyType (DbList _ _) = DbInt64
simplifyType x = x
defaultPriority :: Int
defaultPriority = 0
referencePriority :: Int
referencePriority = 1
functionPriority :: Int
functionPriority = 2
triggerPriority :: Int
triggerPriority = 3
mainTableId :: String
mainTableId = "id"
escape :: String -> String
escape s = '\"' : s ++ "\""
getStatement :: StringS -> PG.Query
getStatement sql = PG.Query $ T.encodeUtf8 $ T.pack $ fromStringS sql ""
queryRawTyped' :: (MonadBaseControl IO m, MonadIO m) => StringS -> [DbType] -> [PersistValue] -> (RowPopper (DbPersist Postgresql m) -> DbPersist Postgresql m a) -> DbPersist Postgresql m a
queryRawTyped' query _ vals f = queryRaw' query vals f
queryRaw' :: (MonadBaseControl IO m, MonadIO m) => StringS -> [PersistValue] -> (RowPopper (DbPersist Postgresql m) -> DbPersist Postgresql m a) -> DbPersist Postgresql m a
queryRaw' query vals f = do
Postgresql conn <- DbPersist ask
rawquery <- liftIO $ PG.formatQuery conn (getStatement query) (map P vals)
(ret, rowRef, rowCount, getters) <- liftIO $ PG.withConnection conn $ \rawconn -> do
mret <- LibPQ.exec rawconn rawquery
case mret of
Nothing -> do
merr <- LibPQ.errorMessage rawconn
fail $ case merr of
Nothing -> "Postgresql.withStmt': unknown error"
Just e -> "Postgresql.withStmt': " ++ unpack e
Just ret -> do
status <- LibPQ.resultStatus ret
case status of
LibPQ.TuplesOk -> return ()
_ -> do
msg <- LibPQ.resStatus status
merr <- LibPQ.errorMessage rawconn
fail $ "Postgresql.withStmt': bad result status " ++
show status ++ " (" ++ show msg ++ ")" ++
maybe "" ((". Error message: "++) . unpack) merr
cols <- LibPQ.nfields ret
getters <- forM [0..cols1] $ \col -> do
oid <- LibPQ.ftype ret col
case PG.oid2builtin oid of
Nothing -> fail $ "Postgresql.withStmt': could not " ++
"recognize Oid of column " ++
show (let LibPQ.Col i = col in i) ++
" (counting from zero)"
Just bt -> return $ getGetter bt $
PG.Field ret col $
PG.builtin2typname bt
rowRef <- newIORef (LibPQ.Row 0)
rowCount <- LibPQ.ntuples ret
return (ret, rowRef, rowCount, getters)
f $ liftIO $ do
row <- atomicModifyIORef rowRef (\r -> (r+1, r))
if row == rowCount
then return Nothing
else liftM Just $ forM (zip getters [0..]) $ \(getter, col) -> do
mbs <- LibPQ.getvalue' ret row col
case mbs of
Nothing -> return PersistNull
Just bs -> bs `seq` case getter mbs of
Errors (exc:_) -> throw exc
Errors [] -> error "Got an Errors, but no exceptions"
Ok v -> return v
newtype P = P PersistValue
instance PGTF.ToField P where
toField (P (PersistString t)) = PGTF.toField t
toField (P (PersistByteString bs)) = PGTF.toField (PG.Binary bs)
toField (P (PersistInt64 i)) = PGTF.toField i
toField (P (PersistDouble d)) = PGTF.toField d
toField (P (PersistBool b)) = PGTF.toField b
toField (P (PersistDay d)) = PGTF.toField d
toField (P (PersistTimeOfDay t)) = PGTF.toField t
toField (P (PersistUTCTime t)) = PGTF.toField t
toField (P (PersistZonedTime (ZT t))) = PGTF.toField t
toField (P PersistNull) = PGTF.toField PG.Null
type Getter a = PG.Field -> Maybe ByteString -> Ok a
convertPV :: PGFF.FromField a => (a -> b) -> Getter b
convertPV f = (fmap f .) . PGFF.fromField
getGetter :: PG.BuiltinType -> Getter PersistValue
getGetter PG.Bool = convertPV PersistBool
getGetter PG.ByteA = convertPV (PersistByteString . unBinary)
getGetter PG.Char = convertPV PersistString
getGetter PG.Name = convertPV PersistString
getGetter PG.Int8 = convertPV PersistInt64
getGetter PG.Int2 = convertPV PersistInt64
getGetter PG.Int4 = convertPV PersistInt64
getGetter PG.Text = convertPV PersistString
getGetter PG.Xml = convertPV PersistString
getGetter PG.Float4 = convertPV PersistDouble
getGetter PG.Float8 = convertPV PersistDouble
getGetter PG.AbsTime = convertPV PersistUTCTime
getGetter PG.RelTime = convertPV PersistUTCTime
getGetter PG.BpChar = convertPV PersistString
getGetter PG.VarChar = convertPV PersistString
getGetter PG.Date = convertPV PersistDay
getGetter PG.Time = convertPV PersistTimeOfDay
getGetter PG.Timestamp = convertPV (PersistUTCTime . localTimeToUTC utc)
getGetter PG.TimestampTZ = convertPV (PersistZonedTime . ZT)
getGetter PG.Bit = convertPV PersistInt64
getGetter PG.VarBit = convertPV PersistInt64
getGetter PG.Numeric = convertPV (PersistDouble . fromRational)
getGetter PG.Void = \_ _ -> Ok PersistNull
getGetter _ = \f dat -> fmap (PersistByteString . unBinary) $ case dat of
Nothing -> PGFF.returnError PGFF.UnexpectedNull f ""
Just str -> case PGFF.format f of
LibPQ.Text -> case unsafePerformIO (LibPQ.unescapeBytea str) of
Nothing -> PGFF.returnError PGFF.ConversionFailed f "unescapeBytea failed"
Just str' -> return $ PG.Binary str'
LibPQ.Binary -> return $ PG.Binary $ copy $ str
unBinary :: PG.Binary a -> a
unBinary (PG.Binary x) = x
proxy :: Proxy Postgresql
proxy = error "Proxy Postgresql"