diff --git a/Database/Persist/Postgresql.hs b/Database/Persist/Postgresql.hs --- a/Database/Persist/Postgresql.hs +++ b/Database/Persist/Postgresql.hs @@ -2,24 +2,22 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} + -- | A postgresql backend for persistent. module Database.Persist.Postgresql ( withPostgresqlPool , withPostgresqlConn , createPostgresqlPool - , module Database.Persist - , module Database.Persist.GenericSql + , module Database.Persist.Sql , ConnectionString , PostgresConf (..) , openSimpleConn ) where -import Database.Persist hiding (Entity (..)) -import Database.Persist.Store -import Database.Persist.GenericSql hiding (Key) -import Database.Persist.GenericSql.Internal -import Database.Persist.EntityDef +import Database.Persist.Sql import Data.Maybe (mapMaybe) +import Data.Fixed (Pico) import qualified Database.PostgreSQL.Simple as PG import qualified Database.PostgreSQL.Simple.BuiltinTypes as PG @@ -47,6 +45,7 @@ import qualified Data.ByteString.Char8 as B8 import qualified Data.Text as T import qualified Data.Text.Encoding as T +import qualified Blaze.ByteString.Builder.Char8 as BBB import Data.Time.LocalTime (localTimeToUTC, utc) import Data.Text (Text, pack) import Data.Aeson @@ -111,26 +110,27 @@ openSimpleConn conn = do smap <- newIORef $ Map.empty return Connection - { prepare = prepare' conn - , stmtMap = smap - , insertSql = insertSql' - , close = PG.close conn - , migrateSql = migrate' - , begin = const $ PG.begin conn - , commitC = const $ PG.commit conn - , rollbackC = const $ PG.rollback conn - , escapeName = escape - , noLimit = "LIMIT ALL" + { connPrepare = prepare' conn + , connStmtMap = smap + , connInsertSql = insertSql' + , connClose = PG.close conn + , connMigrateSql = migrate' + , connBegin = const $ PG.begin conn + , connCommit = const $ PG.commit conn + , connRollback = const $ PG.rollback conn + , connEscapeName = escape + , connNoLimit = "LIMIT ALL" + , connRDBMS = "postgresql" } prepare' :: PG.Connection -> Text -> IO Statement prepare' conn sql = do let query = PG.Query (T.encodeUtf8 sql) return Statement - { finalize = return () - , reset = return () - , execute = execute' conn query - , withStmt = withStmt' conn query + { stmtFinalize = return () + , stmtReset = return () + , stmtExecute = execute' conn query + , stmtQuery = withStmt' conn query } insertSql' :: DBName -> [DBName] -> DBName -> InsertSqlResult @@ -191,8 +191,7 @@ show (let LibPQ.Col i = col in i) ++ " (counting from zero)" Just bt -> return $ getGetter bt $ - PG.Field ret col $ - PG.builtin2typname bt + PG.Field ret col oid -- Ready to go! rowRef <- newIORef (LibPQ.Row 0) rowCount <- LibPQ.ntuples ret @@ -214,7 +213,9 @@ mbs <- LibPQ.getvalue' ret row col case mbs of Nothing -> return PersistNull - Just bs -> bs `seq` case getter mbs of + Just bs -> do + ok <- PGFF.runConversion (getter mbs) conn + bs `seq` case ok of Errors (exc:_) -> throw exc Errors [] -> error "Got an Errors, but no exceptions" Ok v -> return v @@ -222,11 +223,15 @@ -- | Avoid orphan instances. newtype P = P PersistValue + instance PGTF.ToField P where toField (P (PersistText 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 (PersistRational r)) = PGTF.Plain $ + BBB.fromString $ + show (fromRational r :: Pico) -- FIXME: Too Ambigous, can not select precision without information about field toField (P (PersistBool b)) = PGTF.toField b toField (P (PersistDay d)) = PGTF.toField d toField (P (PersistTimeOfDay t)) = PGTF.toField t @@ -238,7 +243,7 @@ toField (P (PersistObjectId _)) = error "Refusing to serialize a PersistObjectId to a PostgreSQL value" -type Getter a = PG.Field -> Maybe ByteString -> Ok a +type Getter a = PGFF.FieldParser a convertPV :: PGFF.FromField a => (a -> b) -> Getter b convertPV f = (fmap f .) . PGFF.fromField @@ -267,22 +272,21 @@ 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 PG.Numeric = convertPV PersistRational +getGetter PG.Void = \_ _ -> return PersistNull getGetter other = error $ "Postgresql.getGetter: type " ++ show other ++ " not supported." unBinary :: PG.Binary a -> a unBinary (PG.Binary x) = x -migrate' :: PersistEntity val - => [EntityDef] +migrate' :: [EntityDef a] -> (Text -> IO Statement) - -> val + -> EntityDef SqlType -> IO (Either [Text] [(Bool, Text)]) migrate' allDefs getter val = fmap (fmap $ map showAlterDb) $ do - let name = entityDB $ entityDef val - old <- getColumns getter $ entityDef val + let name = entityDB val + old <- getColumns getter val case partitionEithers old of ([], old'') -> do let old' = partitionEithers old'' @@ -294,7 +298,7 @@ [ "CREATe TABLE " , T.unpack $ escape name , "(" - , T.unpack $ escape $ entityID $ entityDef val + , T.unpack $ escape $ entityID val , " SERIAL PRIMARY KEY UNIQUE" , concatMap (\x -> ',' : showColumn x) $ fst new , ")" @@ -310,8 +314,8 @@ return $ Right $ acs' ++ ats' (errs, _) -> return $ Left errs -data AlterColumn = Type SqlType | IsNull | NotNull | Add Column | Drop - | Default String | NoDefault | Update String +data AlterColumn = Type SqlType | IsNull | NotNull | Add' Column | Drop + | Default String | NoDefault | Update' String | AddReference DBName | DropReference DBName type AlterColumn' = (DBName, AlterColumn) @@ -324,18 +328,18 @@ -- | Returns all of the columns in the given table currently in the database. getColumns :: (Text -> IO Statement) - -> EntityDef + -> EntityDef a -> IO [Either Text (Either Column (DBName, [DBName]))] getColumns getter def = do - stmt <- getter "SELECT column_name,is_nullable,udt_name,column_default FROM information_schema.columns WHERE table_name=? AND column_name <> ?" + stmt <- getter "SELECT column_name,is_nullable,udt_name,column_default,numeric_precision,numeric_scale FROM information_schema.columns WHERE table_name=? AND column_name <> ?" let vals = [ PersistText $ unDBName $ entityDB def , PersistText $ unDBName $ entityID def ] - cs <- runResourceT $ withStmt stmt vals $$ helper + cs <- runResourceT $ stmtQuery stmt vals $$ helper stmt' <- getter "SELECT constraint_name, column_name FROM information_schema.constraint_column_usage WHERE table_name=? AND column_name <> ? ORDER BY constraint_name, column_name" - us <- runResourceT $ withStmt stmt' vals $$ helperU + us <- runResourceT $ stmtQuery stmt' vals $$ helperU return $ cs ++ us where getAll front = do @@ -393,7 +397,7 @@ getColumn :: (Text -> IO Statement) -> DBName -> [PersistValue] -> IO (Either Text Column) -getColumn getter tname [PersistText x, PersistText y, PersistText z, d] = +getColumn getter tname [PersistText x, PersistText y, PersistText z, d, npre, nscl] = case d' of Left s -> return $ Left s Right d'' -> @@ -402,7 +406,14 @@ Right t -> do let cname = DBName x ref <- getRef cname - return $ Right $ Column cname (y == "YES") t d'' Nothing ref + return $ Right Column + { cName = cname + , cNull = y == "YES" + , cSqlType = t + , cDefault = d'' + , cMaxLen = Nothing + , cReference = ref + } where getRef cname = do let sql = pack $ concat @@ -414,7 +425,7 @@ ] let ref = refName tname cname stmt <- getter sql - runResourceT $ withStmt stmt + runResourceT $ stmtQuery stmt [ PersistText $ unDBName tname , PersistText $ unDBName ref ] $$ do @@ -435,15 +446,19 @@ getType "float8" = Right $ SqlReal getType "bytea" = Right $ SqlBlob getType "time" = Right $ SqlTime + getType "numeric" = getNumeric npre nscl getType a = Right $ SqlOther a + + getNumeric (PersistInt64 a) (PersistInt64 b) = Right $ SqlNumeric (fromIntegral a) (fromIntegral b) + getNumeric a b = Left $ pack $ "Can not get numeric field precision, got: " ++ show a ++ " and " ++ show b ++ " as precision and scale" getColumn _ _ x = return $ Left $ pack $ "Invalid result from information_schema: " ++ show x findAlters :: Column -> [Column] -> ([AlterColumn'], [Column]) -findAlters col@(Column name isNull type_ def _maxLen ref) cols = +findAlters col@(Column name isNull sqltype def _maxLen ref) cols = case filter (\c -> cName c == name) cols of - [] -> ([(name, Add col)], cols) - Column _ isNull' type_' def' _maxLen' ref':_ -> + [] -> ([(name, Add' col)], cols) + Column _ isNull' sqltype' def' _maxLen' ref':_ -> let refDrop Nothing = [] refDrop (Just (_, cname)) = [(name, DropReference cname)] refAdd Nothing = [] @@ -457,10 +472,10 @@ (False, True) -> let up = case def of Nothing -> id - Just s -> (:) (name, Update $ T.unpack s) + Just s -> (:) (name, Update' $ T.unpack s) in up [(name, NotNull)] _ -> [] - modType = if type_ == type_' then [] else [(name, Type type_)] + modType = if sqltype == sqltype' then [] else [(name, Type sqltype)] modDef = if def == def' then [] @@ -472,16 +487,16 @@ -- | Get the references to be added to a table for the given column. getAddReference :: DBName -> Column -> Maybe AlterDB -getAddReference table (Column n _nu _t _def _maxLen ref) = +getAddReference table (Column n _nu _ _def _maxLen ref) = case ref of Nothing -> Nothing Just (s, _) -> Just $ AlterColumn table (n, AddReference s) showColumn :: Column -> String -showColumn (Column n nu t def _maxLen ref) = concat +showColumn (Column n nu sqlType def _maxLen _ref) = concat [ T.unpack $ escape n , " " - , showSqlType t + , showSqlType sqlType , " " , if nu then "NULL" else "NOT NULL" , case def of @@ -494,6 +509,7 @@ showSqlType SqlInt32 = "INT4" showSqlType SqlInt64 = "INT8" showSqlType SqlReal = "DOUBLE PRECISION" +showSqlType (SqlNumeric s prec) = "NUMERIC(" ++ show s ++ "," ++ show prec ++ ")" showSqlType SqlDay = "DATE" showSqlType SqlTime = "TIME" showSqlType SqlDayTime = "TIMESTAMP" @@ -554,7 +570,7 @@ , T.unpack $ escape n , " SET NOT NULL" ] -showAlter table (_, Add col) = +showAlter table (_, Add' col) = concat [ "ALTER TABLE " , T.unpack $ escape table @@ -584,7 +600,7 @@ , T.unpack $ escape n , " DROP DEFAULT" ] -showAlter table (n, Update s) = concat +showAlter table (n, Update' s) = concat [ "UPDATE " , T.unpack $ escape table , " SET " @@ -631,7 +647,7 @@ } instance PersistConfig PostgresConf where - type PersistConfigBackend PostgresConf = SqlPersist + type PersistConfigBackend PostgresConf = SqlPersistT type PersistConfigPool PostgresConf = ConnectionPool createPoolConfig (PostgresConf cs size) = createPostgresqlPool cs size runPool _ = runSqlPool diff --git a/persistent-postgresql.cabal b/persistent-postgresql.cabal --- a/persistent-postgresql.cabal +++ b/persistent-postgresql.cabal @@ -1,5 +1,5 @@ name: persistent-postgresql -version: 1.1.3.1 +version: 1.2.0 license: MIT license-file: LICENSE author: Felipe Lessa, Michael Snoyman @@ -15,13 +15,14 @@ library build-depends: base >= 4 && < 5 , transformers >= 0.2.1 - , postgresql-simple >= 0.2 && < 0.3 + , postgresql-simple >= 0.3 && < 0.4 , postgresql-libpq >= 0.6.1 && < 0.9 - , persistent >= 1.1.5 && < 1.2 + , persistent >= 1.2 && < 1.3 , containers >= 0.2 , bytestring >= 0.9 , text >= 0.7 , monad-control >= 0.2 + , blaze-builder , time >= 1.1 , aeson >= 0.5 , conduit >= 0.5.3