Permalink
Browse files

First stab at migrating to pgsql-simple

  • Loading branch information...
1 parent 992afd3 commit 9c14812f3f22c9bb25a71cf0bf3ef68591d78daf @snoyberg snoyberg committed Oct 6, 2011
@@ -1,23 +1,23 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
-- | A postgresql backend for persistent.
module Database.Persist.Postgresql
( withPostgresqlPool
, withPostgresqlConn
, module Database.Persist
, module Database.Persist.GenericSql
, PostgresConf (..)
+ , P.ConnectInfo (..)
+ , P.defaultConnectInfo
) where
import Database.Persist hiding (Update)
import Database.Persist.Base hiding (Add, Update)
import Database.Persist.GenericSql hiding (Key(..))
import Database.Persist.GenericSql.Internal
-import qualified Database.HDBC as H
-import qualified Database.HDBC.PostgreSQL as H
-
-import Control.Monad.IO.Class (MonadIO (..))
import Data.List (intercalate)
import Data.IORef
import qualified Data.Map as Map
@@ -26,51 +26,57 @@ import Control.Arrow
import Data.List (sort, groupBy)
import Data.Function (on)
import Control.Monad.IO.Control (MonadControlIO)
+import Control.Monad.IO.Class (liftIO)
import Data.ByteString (ByteString)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.Encoding.Error as T
-import Data.Time.LocalTime (localTimeToUTC, utc)
-import Data.Text (Text, pack, unpack)
-import Data.Object
-import Control.Monad (forM)
+import Data.Text (Text, pack)
+import Data.Object (fromMapping, lookupScalar, ObjectExtractError)
import Data.Neither (meither, MEither (..))
+import Data.String (fromString)
+
+import qualified Database.PostgreSQL.Simple as P
+import Database.PostgreSQL.Simple.Param (Param (..))
+import Database.PostgreSQL.Simple.QueryResults (QueryResults (..))
+import Database.PostgreSQL.Simple.Result (Result (convert))
+import Database.PostgreSQL.Simple.Types (Null (Null))
withPostgresqlPool :: MonadControlIO m
- => T.Text
+ => P.ConnectInfo
-> Int -- ^ number of connections to open
-> (ConnectionPool -> m a) -> m a
withPostgresqlPool s = withSqlPool $ open' s
-withPostgresqlConn :: MonadControlIO m => T.Text -> (Connection -> m a) -> m a
+withPostgresqlConn :: MonadControlIO m => P.ConnectInfo -> (Connection -> m a) -> m a
withPostgresqlConn = withSqlConn . open'
-open' :: T.Text -> IO Connection
+open' :: P.ConnectInfo -> IO Connection
open' s = do
- conn <- H.connectPostgreSQL $ T.unpack s
- smap <- newIORef $ Map.empty
+ conn <- P.connect s
+ smap <- newIORef Map.empty
return Connection
{ prepare = prepare' conn
, stmtMap = smap
, insertSql = insertSql'
- , close = H.disconnect conn
+ , close = P.close conn
, migrateSql = migrate'
, begin = const $ return ()
- , commitC = const $ H.commit conn
- , rollbackC = const $ H.rollback conn
+ , commitC = const $ P.commit conn
+ , rollbackC = const $ P.rollback conn
, escapeName = escape
, noLimit = "LIMIT ALL"
}
-prepare' :: H.Connection -> Text -> IO Statement
+prepare' :: P.Connection -> Text -> IO Statement
prepare' conn sql = do
- stmt <- H.prepare conn $ unpack sql
+ let query = fromString $ T.unpack sql
return Statement
{ finalize = return ()
, reset = return ()
- , execute = execute' stmt
- , withStmt = withStmt' stmt
+ , execute = execute' conn query
+ , withStmt = withStmt' conn query
}
insertSql' :: RawName -> [RawName] -> Either Text (Text, Text)
@@ -84,52 +90,46 @@ insertSql' t cols = Left $ pack $ concat
, ") RETURNING id"
]
-execute' :: H.Statement -> [PersistValue] -> IO ()
-execute' stmt vals = do
- _ <- H.execute stmt $ map pToSql vals
+execute' :: P.Connection -> P.Query -> [PersistValue] -> IO ()
+execute' conn query vals = do
+ _ <- P.execute conn query vals
return ()
withStmt' :: MonadControlIO m
- => H.Statement
+ => P.Connection
+ -> P.Query
-> [PersistValue]
-> (RowPopper m -> m a)
-> m a
-withStmt' stmt vals f = do
- _ <- liftIO $ H.execute stmt $ map pToSql vals
- f $ liftIO $ (fmap . fmap) (map pFromSql) $ H.fetchRow stmt
-
-pToSql :: PersistValue -> H.SqlValue
-pToSql (PersistText t) = H.SqlString $ unpack t
-pToSql (PersistByteString bs) = H.SqlByteString bs
-pToSql (PersistInt64 i) = H.SqlInt64 i
-pToSql (PersistDouble d) = H.SqlDouble d
-pToSql (PersistBool b) = H.SqlBool b
-pToSql (PersistDay d) = H.SqlLocalDate d
-pToSql (PersistTimeOfDay t) = H.SqlLocalTimeOfDay t
-pToSql (PersistUTCTime t) = H.SqlUTCTime t
-pToSql PersistNull = H.SqlNull
-pToSql (PersistList _) = error "Refusing to serialize a PersistList to a PostgreSQL value"
-pToSql (PersistMap _) = error "Refusing to serialize a PersistMap to a PostgreSQL value"
-pToSql (PersistObjectId _) = error "Refusing to serialize a PersistObjectId to a PostgreSQL value"
-
-pFromSql :: H.SqlValue -> PersistValue
-pFromSql (H.SqlString s) = PersistText $ pack s
-pFromSql (H.SqlByteString bs) = PersistByteString bs
-pFromSql (H.SqlWord32 i) = PersistInt64 $ fromIntegral i
-pFromSql (H.SqlWord64 i) = PersistInt64 $ fromIntegral i
-pFromSql (H.SqlInt32 i) = PersistInt64 $ fromIntegral i
-pFromSql (H.SqlInt64 i) = PersistInt64 $ fromIntegral i
-pFromSql (H.SqlInteger i) = PersistInt64 $ fromIntegral i
-pFromSql (H.SqlChar c) = PersistInt64 $ fromIntegral $ fromEnum c
-pFromSql (H.SqlBool b) = PersistBool b
-pFromSql (H.SqlDouble b) = PersistDouble b
-pFromSql (H.SqlRational b) = PersistDouble $ fromRational b
-pFromSql (H.SqlLocalDate d) = PersistDay d
-pFromSql (H.SqlLocalTimeOfDay d) = PersistTimeOfDay d
-pFromSql (H.SqlUTCTime d) = PersistUTCTime d
-pFromSql H.SqlNull = PersistNull
-pFromSql (H.SqlLocalTime d) = PersistUTCTime $ localTimeToUTC utc d
-pFromSql x = PersistText $ pack $ H.fromSql x -- FIXME
+withStmt' conn query vals f = do
+ iresult <- liftIO $ P.query conn query vals >>= newIORef
+ f $ pop iresult
+ where
+ pop ir = liftIO $ atomicModifyIORef ir $ \res ->
+ case res of
+ [] -> ([], Nothing)
+ (r:rs) -> (rs, Just r)
+
+instance Param PersistValue where
+ render (PersistText t) = render t
+ render (PersistByteString bs) = render bs
+ render (PersistInt64 i) = render i
+ render (PersistDouble d) = render d
+ render (PersistBool b) = render b
+ render (PersistDay d) = render d
+ render (PersistTimeOfDay t) = render t
+ render (PersistUTCTime t) = render t
+ render PersistNull = render Null
+ render PersistList{} = error "Refusing to serialize a PersistList to a PostgreSQL value"
+ render PersistMap{} = error "Refusing to serialize a PersistMap to a PostgreSQL value"
+ render PersistObjectId{} = error "Refusing to serialize a PersistObjectId to a PostgreSQL value"
+
+instance QueryResults [PersistValue] where
+ convertResults = zipWith convert
+
+instance Result PersistValue where
+ convert _ Nothing = PersistNull
+ convert _ (Just bs) = PersistByteString bs -- FIXME
migrate' :: PersistEntity val
=> (Text -> IO Statement)
@@ -455,7 +455,7 @@ bsToChars = T.unpack . T.decodeUtf8With T.lenientDecode
-- | Information required to connect to a postgres database
data PostgresConf = PostgresConf
- { pgConnStr :: Text
+ { pgConnStr :: P.ConnectInfo
, pgPoolSize :: Int
}
@@ -466,10 +466,11 @@ instance PersistConfig PostgresConf where
runPool _ = runSqlPool
loadConfig e' = meither Left Right $ do
e <- go $ fromMapping e'
- db <- go $ lookupScalar "database" e
+ _db <- go $ lookupScalar "database" e
pool' <- go $ lookupScalar "poolsize" e
- pool <- safeRead "poolsize" pool'
+ _pool <- safeRead "poolsize" pool'
+ error "FIXME" {-
-- TODO: default host/port?
connparts <- forM ["user", "password", "host", "port"] $ \k -> do
v <- go $ lookupScalar k e
@@ -478,6 +479,7 @@ instance PersistConfig PostgresConf where
let conn = T.concat connparts
return $ PostgresConf (T.concat [conn, " dbname=", db]) pool
+ -}
where
go :: MEither ObjectExtractError a -> MEither String a
go (MLeft e) = MLeft $ show e
@@ -1,5 +1,5 @@
name: persistent-postgresql
-version: 0.6.1
+version: 0.7.0
license: BSD3
license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com>
@@ -14,9 +14,8 @@ homepage: http://www.yesodweb.com/book/persistent
library
build-depends: base >= 4 && < 5
- , HDBC >= 2.2.6 && < 2.4
, transformers >= 0.2.1 && < 0.3
- , HDBC-postgresql >= 2.2.3.1 && < 2.4
+ , pgsql-simple >= 0.1.1 && < 0.2
, persistent >= 0.6.3 && < 0.7
, containers >= 0.2 && < 0.5
, bytestring >= 0.9 && < 0.10
@@ -51,9 +51,10 @@ test-suite test
, time >= 1.2
, random == 1.*
, QuickCheck == 2.4.*
+ , pgsql-simple
-- these are mutually exclusive options
- -- cpp-options: -DWITH_POSTGRESQL
+ cpp-options: -DWITH_POSTGRESQL
-- cpp-options: -DWITH_MONGODB -DDEBUG
ghc-options: -Wall
extra-libraries: sqlite3
@@ -196,7 +196,13 @@ runConn :: Control.Monad.IO.Control.MonadControlIO m => SqlPersist m t -> m ()
runConn f = do
_<-withSqlitePool sqlite_database 1 $ runSqlPool f
#if WITH_POSTGRESQL
- _<-withPostgresqlPool "user=test password=test host=localhost port=5432 dbname=test" 1 $ runSqlPool f
+ _<-withPostgresqlPool defaultConnectInfo
+ { connectUser = "test"
+ , connectPort = 5432
+ , connectPassword = "test"
+ , connectDatabase = "test"
+ , connectHost = "localhost"
+ } 1 $ runSqlPool f
#endif
return ()

1 comment on commit 9c14812

Owner

meteficha commented on 9c14812 Dec 29, 2011

Michael, what was the fate of this branch? I was bitten by the ByteString bug just now so I'm planning to revive it. What went wrong?

Please sign in to comment.