persistent-postgresql 0.4.0.1 → 0.5.0
raw patch · 2 files changed
+43/−48 lines, 2 filesdep +monad-controldep −monad-peeldep −template-haskelldep ~persistent
Dependencies added: monad-control
Dependencies removed: monad-peel, template-haskell
Dependency ranges changed: persistent
Files
Database/Persist/Postgresql.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE PackageImports #-}+{-# LANGUAGE OverloadedStrings #-} -- | A postgresql backend for persistent. module Database.Persist.Postgresql ( withPostgresqlPool@@ -23,26 +23,27 @@ import Control.Arrow import Data.List (sort, groupBy) import Data.Function (on)-import Control.Monad.IO.Peel (MonadPeelIO)+import Control.Monad.IO.Control (MonadControlIO) 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) -withPostgresqlPool :: MonadPeelIO m- => String+withPostgresqlPool :: MonadControlIO m+ => T.Text -> Int -- ^ number of connections to open -> (ConnectionPool -> m a) -> m a withPostgresqlPool s = withSqlPool $ open' s -withPostgresqlConn :: MonadPeelIO m => String -> (Connection -> m a) -> m a+withPostgresqlConn :: MonadControlIO m => T.Text -> (Connection -> m a) -> m a withPostgresqlConn = withSqlConn . open' -open' :: String -> IO Connection+open' :: T.Text -> IO Connection open' s = do- conn <- H.connectPostgreSQL s+ conn <- H.connectPostgreSQL $ T.unpack s smap <- newIORef $ Map.empty return Connection { prepare = prepare' conn@@ -57,9 +58,9 @@ , noLimit = "LIMIT ALL" } -prepare' :: H.Connection -> String -> IO Statement+prepare' :: H.Connection -> Text -> IO Statement prepare' conn sql = do- stmt <- H.prepare conn sql+ stmt <- H.prepare conn $ unpack sql return Statement { finalize = return () , reset = return ()@@ -67,8 +68,8 @@ , withStmt = withStmt' stmt } -insertSql' :: RawName -> [RawName] -> Either String (String, String)-insertSql' t cols = Left $ concat+insertSql' :: RawName -> [RawName] -> Either Text (Text, Text)+insertSql' t cols = Left $ pack $ concat [ "INSERT INTO " , escape t , "("@@ -83,7 +84,7 @@ _ <- H.execute stmt $ map pToSql vals return () -withStmt' :: MonadPeelIO m+withStmt' :: MonadControlIO m => H.Statement -> [PersistValue] -> (RowPopper m -> m a)@@ -93,7 +94,7 @@ f $ liftIO $ (fmap . fmap) (map pFromSql) $ H.fetchRow stmt pToSql :: PersistValue -> H.SqlValue-pToSql (PersistString s) = H.SqlString s+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@@ -102,9 +103,12 @@ 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 (PersistForeignKey _) = error "Refusing to serialize a PersistForeignKey to a PostgreSQL value" pFromSql :: H.SqlValue -> PersistValue-pFromSql (H.SqlString s) = PersistString s+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@@ -120,12 +124,12 @@ pFromSql (H.SqlUTCTime d) = PersistUTCTime d pFromSql H.SqlNull = PersistNull pFromSql (H.SqlLocalTime d) = PersistUTCTime $ localTimeToUTC utc d-pFromSql x = PersistString $ H.fromSql x -- FIXME+pFromSql x = PersistText $ pack $ H.fromSql x -- FIXME migrate' :: PersistEntity val- => (String -> IO Statement)+ => (Text -> IO Statement) -> val- -> IO (Either [String] [(Bool, String)])+ -> IO (Either [Text] [(Bool, Text)]) migrate' getter val = do let name = rawTableName $ entityDef val old <- getColumns getter name@@ -165,21 +169,14 @@ | AlterTable RawName AlterTable -- | Returns all of the columns in the given table currently in the database.-getColumns :: (String -> IO Statement)- -> RawName -> IO [Either String (Either Column UniqueDef)]+getColumns :: (Text -> IO Statement)+ -> RawName -> IO [Either Text (Either Column UniqueDef)] getColumns getter name = do- stmt <- getter $- "SELECT column_name,is_nullable,udt_name,column_default " ++- "FROM information_schema.columns " ++- "WHERE table_name=? AND column_name <> 'id'"- cs <- withStmt stmt [PersistString $ unRawName name] helper- stmt' <- getter $ concat- [ "SELECT constraint_name, column_name "- , "FROM information_schema.constraint_column_usage "- , "WHERE table_name=? AND column_name <> 'id' "- , "ORDER BY constraint_name, column_name"- ]- us <- withStmt stmt' [PersistString $ unRawName name] helperU+ stmt <- getter "SELECT column_name,is_nullable,udt_name,column_default FROM information_schema.columns WHERE table_name=? AND column_name <> 'id'"+ cs <- withStmt stmt [PersistText $ pack $ unRawName name] helper+ stmt' <- getter+ "SELECT constraint_name, column_name FROM information_schema.constraint_column_usage WHERE table_name=? AND column_name <> 'id' ORDER BY constraint_name, column_name"+ us <- withStmt stmt' [PersistText $ pack $ unRawName name] helperU return $ cs ++ us where getAll pop front = do@@ -227,9 +224,9 @@ : AddUniqueConstraint name cols : getAltersU news old' -getColumn :: (String -> IO Statement)+getColumn :: (Text -> IO Statement) -> RawName -> [PersistValue]- -> IO (Either String Column)+ -> IO (Either Text Column) getColumn getter tname [PersistByteString x, PersistByteString y, PersistByteString z, d] =@@ -245,7 +242,7 @@ t d'' ref where getRef cname = do- let sql = concat+ let sql = pack $ concat [ "SELECT COUNT(*) FROM " , "information_schema.table_constraints " , "WHERE table_name=? "@@ -255,15 +252,15 @@ let ref = refName tname cname stmt <- getter sql withStmt stmt- [ PersistString $ unRawName tname- , PersistString $ unRawName ref+ [ PersistText $ pack $ unRawName tname+ , PersistText $ pack $ unRawName ref ] $ \pop -> do Just [PersistInt64 i] <- pop return $ if i == 0 then Nothing else Just (RawName "", ref) d' = case d of PersistNull -> Right Nothing PersistByteString a -> Right $ Just $ bsToChars a- _ -> Left $ "Invalid default column: " ++ show d+ _ -> Left $ pack $ "Invalid default column: " ++ show d getType "int4" = Right $ SqlInt32 getType "int8" = Right $ SqlInteger getType "varchar" = Right $ SqlString@@ -273,9 +270,9 @@ getType "float4" = Right $ SqlReal getType "float8" = Right $ SqlReal getType "bytea" = Right $ SqlBlob- getType a = Left $ "Unknown type: " ++ a+ getType a = Left $ pack $ "Unknown type: " ++ a getColumn _ _ x =- return $ Left $ "Invalid result from information_schema: " ++ show x+ return $ Left $ pack $ "Invalid result from information_schema: " ++ show x findAlters :: Column -> [Column] -> ([AlterColumn'], [Column]) findAlters col@(Column name isNull type_ def ref) cols =@@ -334,14 +331,14 @@ showSqlType SqlBlob = "BYTEA" showSqlType SqlBool = "BOOLEAN" -showAlterDb :: AlterDB -> (Bool, String)-showAlterDb (AddTable s) = (False, s)+showAlterDb :: AlterDB -> (Bool, Text)+showAlterDb (AddTable s) = (False, pack s) showAlterDb (AlterColumn t (c, ac)) =- (isUnsafe ac, showAlter t (c, ac))+ (isUnsafe ac, pack $ showAlter t (c, ac)) where isUnsafe Drop = True isUnsafe _ = False-showAlterDb (AlterTable t at) = (False, showAlterTable t at)+showAlterDb (AlterTable t at) = (False, pack $ showAlterTable t at) showAlterTable :: RawName -> AlterTable -> String showAlterTable table (AddUniqueConstraint cname cols) = concat
persistent-postgresql.cabal view
@@ -1,5 +1,5 @@ name: persistent-postgresql-version: 0.4.0.1+version: 0.5.0 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -14,15 +14,14 @@ library build-depends: base >= 4 && < 5- , template-haskell , HDBC >= 2.2.6 && < 2.3 , transformers >= 0.2.1 && < 0.3 , HDBC-postgresql >= 2.2.3.1 && < 2.3- , persistent >= 0.4 && < 0.5+ , persistent >= 0.5 && < 0.6 , containers >= 0.2 && < 0.5 , bytestring >= 0.9 && < 0.10 , text >= 0.7 && < 0.12- , monad-peel >= 0.1 && < 0.2+ , monad-control >= 0.2 && < 0.3 , time >= 1.1 && < 1.3 exposed-modules: Database.Persist.Postgresql ghc-options: -Wall@@ -30,4 +29,3 @@ source-repository head type: git location: git://github.com/snoyberg/persistent.git-