hdbi-postgresql 1.0.0 → 1.1.0

raw patch · 4 files changed

+61/−211 lines, 4 filesdep +hdbi-testsdep ~Decimaldep ~hdbiPVP ok

version bump matches the API change (PVP)

Dependencies added: hdbi-tests

Dependency ranges changed: Decimal, hdbi

API changes (from Hackage documentation)

Files

• Database/HDBI/PostgreSQL.hs +1/−0
• Database/HDBI/PostgreSQL/Implementation.hs +16/−12
• hdbi-postgresql.cabal +7/−6
• testsrc/runtests.hs +37/−193

@@ -25,6 +25,7 @@        , PostgreStatement(..)        , PGStatementState(..)        , connectPostgreSQL+       , pgAffectedRows        ) where  import Database.HDBI.PostgreSQL.Implementation

@@ -24,6 +24,8 @@          -- * Connection functions        , connectPostgreSQL        , withPGConnection+         -- * Statement functions+       , pgAffectedRows          -- * Data manipulating functions        , sqlValueToNative        , formatUTC@@ -193,18 +195,6 @@                                      else return StatementExecuted     STFinished    -> return StatementFinished -  affectedRows stmt = withMVar (stState stmt)-                      $ \st -> do-    let res = pgstGetResult "Statement is not executed or already finished" st-    tpls <- PQ.cmdTuples res-    case tpls of-      Nothing -> withPGConnection (stConnection stmt) throwErrorMessage-      Just "" -> return 0        -- when query was SELECT libPQ return empty string-      Just r  -> let rx = TL.unpack $ decodeUTF8 r-                 in case readMay rx of-                   Just x -> return x-                   Nothing -> throwIO $ SqlDriverError $ pgMsg $ "Could not read binding output as integer \"" ++ rx ++ "\""-   finish stmt = modifyMVar_ (stState stmt) doFinishStatement    reset stmt = modifyMVar_ (stState stmt) $ \st -> do@@ -496,6 +486,20 @@   errm <- throwNoMessage =<< PQ.resultErrorMessage res   ef <- throwNoMessage =<< PQ.resultErrorField res PQ.DiagSqlstate   throwIO $ SqlError (TL.unpack $ decodeUTF8 ef) (TL.unpack $ decodeUTF8 errm)++-- | Get the count of rows affected by UPDATE, DELETE or INSERT query+pgAffectedRows :: PostgreStatement -> IO Integer+pgAffectedRows stmt = withMVar (stState stmt)+                      $ \st -> do+  let res = pgstGetResult "Statement is not executed or already finished" st+  tpls <- PQ.cmdTuples res+  case tpls of+    Nothing -> withPGConnection (stConnection stmt) throwErrorMessage+    Just "" -> return 0        -- when query was SELECT libPQ return empty string+    Just r  -> let rx = TL.unpack $ decodeUTF8 r+               in case readMay rx of+                 Just x -> return x+                 Nothing -> throwIO $ SqlDriverError $ pgMsg $ "Could not read binding output as integer \"" ++ rx ++ "\""   -- | Establish new PostgreSQL connection

@@ -1,5 +1,5 @@ Name: hdbi-postgresql-Version: 1.0.0+Version: 1.1.0 License: BSD3 Maintainer: Aleksey Uymanov <s9gf4ult@gmail.com> Author: John Goerzen@@ -26,7 +26,7 @@                , attoparsec                , blaze-builder                , bytestring-               , hdbi >= 1.0.0+               , hdbi >= 1.1.0                , mtl                , old-locale                , postgresql-libpq@@ -50,14 +50,15 @@     ghc-options:   -Wall -fno-warn-orphans -main-is Runtests    build-depends:  base >= 3 && < 5-                 , Decimal+                 , Decimal >= 0.2.1                  , HUnit                  , QuickCheck                  , attoparsec                  , blaze-builder                  , bytestring                  , containers-                 , hdbi >= 1.0.0+                 , hdbi >= 1.1.0+                 , hdbi-tests >= 1.1.0                  , ieee754                  , mtl                  , old-locale@@ -82,14 +83,14 @@     ghc-options:   -Wall -fno-warn-orphans -main-is Puretests    build-depends:  base >= 3 && < 5-                 , Decimal+                 , Decimal >= 0.2.1                  , HUnit                  , QuickCheck                  , attoparsec                  , blaze-builder                  , bytestring                  , derive-                 , hdbi >= 1.0.0+                 , hdbi >= 1.1.0                  , mtl                  , old-locale                  , postgresql-libpq

@@ -7,228 +7,72 @@  module Runtests where -import Control.Applicative-import Data.AEq-import Data.Decimal-import Data.Fixed+import Control.Exception (bracket) import Data.Int-import Data.List-import Data.Monoid-import Data.Time-import Data.UUID-import Data.Word+import Data.List (genericLength) import Database.HDBI import Database.HDBI.PostgreSQL+import Database.HDBI.Tests import System.Environment import System.Exit import Test.Framework import Test.Framework.Providers.HUnit import Test.Framework.Providers.QuickCheck2-import Test.HUnit ((@?=), Assertion)+import Test.HUnit ((@?=)) import Test.QuickCheck import Test.QuickCheck.Assertions-import Test.QuickCheck.Instances ()-import qualified Data.ByteString as B-import qualified Data.Set as S import qualified Data.Text.Lazy as TL import qualified Test.QuickCheck.Monadic as QM  -instance Arbitrary (DecimalRaw Integer) where-  arbitrary = Decimal <$> arbitrary <*> arbitrary -instance Arbitrary UUID where-  arbitrary = fromWords-              <$> arbitrary-              <*> arbitrary-              <*> arbitrary-              <*> arbitrary--runInsertSelect :: (FromSql a, ToSql a) => PostgreConnection -> Query -> a -> IO a-runInsertSelect conn tname val = withTransaction conn $ do-      runRaw conn "drop table if exists table1"-      runRaw conn $ "create table table1 (val " <> tname <> ")"-      run conn "insert into table1 (val) values (?)" [toSql val]-      s <- prepare conn "select val from table1"-      executeRaw s-      (Just [res])<- fetchRow s-      finish s-      return $ fromSql res--runInsertMany :: PostgreConnection -> [String] -> [[SqlValue]] -> IO [[SqlValue]]-runInsertMany conn types values = withTransaction conn $ do-  runRaw conn "drop table if exists table1"-  runRaw conn $ pk $ "create table table1 (" ++ valnames ++ ")"-  s <- prepare conn $ pk $ "insert into table1(" ++ colnames ++ ") values (" ++ (intersperse ',' $ replicate (length names) '?') ++")"-  executeMany s values-  finish s-  s2 <- prepare conn $ pk $ "select " ++ colnames ++ " from table1"-  executeRaw s2-  fetchAllRows s2-  -  where-    pk = Query . TL.pack-    names = map (("val"++) . show) [1..length types]-    colnames = intercalate "," names-    valnames = intercalate "," $ map (\(a, b) -> a ++ " " ++ b) $ zip names types--setsEqual :: PostgreConnection -> [String] -> [[SqlValue]] -> Property-setsEqual conn types values = QM.monadicIO $ do-  ret <- QM.run $ runInsertMany conn types values-  QM.stop $ (S.fromList values) ==? (S.fromList ret)-  -preciseEqual :: (Eq a, Show a, FromSql a, ToSql a) => PostgreConnection -> Query -> a -> Property-preciseEqual conn tname val = QM.monadicIO $ do-  res <- QM.run $ runInsertSelect conn tname val-  QM.stop $ res ?== val---approxEqual :: (Show a, AEq a, FromSql a, ToSql a) => PostgreConnection -> Query -> a -> Property-approxEqual conn tname val = QM.monadicIO $ do-  res <- QM.run $ runInsertSelect conn tname val-  QM.stop $ res ?~== val--genTOD :: Gen TimeOfDay-genTOD = roundTod <$> arbitrary--genLT :: Gen LocalTime-genLT = rnd <$> arbitrary-  where-    rnd x@(LocalTime {localTimeOfDay = t}) = x {localTimeOfDay = roundTod t}---- | Generate Text without 'NUL' symbols-genText :: Gen TL.Text-genText = TL.filter fltr <$> arbitrary-  where-    fltr '\NUL' = False         -- NULL truncates C string when pass to libpq binding.-    fltr _ = True--genUTC :: Gen UTCTime-genUTC = rnd <$> arbitrary-  where-    rnd x@(UTCTime {utctDayTime = d}) = x {utctDayTime = anyToMicro d}----- | Strip TimeOfDay to microsecond precision-roundTod :: TimeOfDay -> TimeOfDay-roundTod x@(TimeOfDay {todSec = s}) = x {todSec = anyToMicro s}--anyToMicro :: (Fractional b, Real a) => a -> b-anyToMicro a = fromRational $ toRational ((fromRational $ toRational a) :: Micro)--testG1 :: PostgreConnection -> Test-testG1 c = testGroup "Can insert and select"-           [ testProperty "Decimal" $ \(d :: Decimal) -> preciseEqual c "decimal(400,255)" d-           , testProperty "Int32" $ \(i :: Int32) -> preciseEqual c "integer" i-           , testProperty "Int64" $ \(i :: Int64) -> preciseEqual c "bigint"  i-           , testProperty "Integer" $ \(i :: Integer) -> preciseEqual c "decimal(100,0)" i-           , testProperty "Double" $ \(d :: Double) -> approxEqual c "double precision" d-           , testProperty "Text" $ forAll genText $ \(t :: TL.Text) -> preciseEqual c "text" t-           , testProperty "ByteString" $ \(b :: B.ByteString) -> preciseEqual c "bytea" b-           , testProperty "Bool" $ \(b :: Bool) -> preciseEqual c "boolean" b-           , testProperty "UUID" $ \(u :: UUID) -> preciseEqual c "uuid" u-           , testProperty "BitField" $ \(w :: Word64) -> preciseEqual c "varbit" (BitField w)-           , testProperty "UTCTime" $ forAll genUTC $ \(u :: UTCTime) -> preciseEqual c "timestamp with time zone" u-           , testProperty "Day" $ \(d :: Day) -> preciseEqual c "date" d-           , testProperty "TimeOfDay" $ forAll genTOD $ \(tod :: TimeOfDay) -> preciseEqual c "time" tod-           , testProperty "LocalTime" $ forAll genLT $ \(lt :: LocalTime) -> preciseEqual c "timestamp without time zone" lt-           , testProperty "Null" $ preciseEqual c "integer" SqlNull-           , testProperty "Maybe Integer" $ \(val :: Maybe Integer) -> preciseEqual c "decimal(100,0)" val-           , testProperty "Maybe ByteString" $ \(val :: Maybe B.ByteString) -> preciseEqual c "bytea" val-           , testProperty "Insert many numbers" $ \(x :: [(Integer, Decimal)]) -> setsEqual c-                                                                          ["decimal(100,0)", "decimal(400,255)"]-                                                                          $ map (\(i, d) ->  [toSql i, toSql d]) x-           , testProperty "Insert many text" $ \(x :: [(Maybe Integer, UUID, Maybe B.ByteString)]) -> setsEqual c-                                                                                                      ["decimal(100,0)", "text", "bytea"]-                                                                                                      $ map (\(i, u, b) ->  [toSql i, toSql u, toSql b]) x-           ]- testAffectedRows :: PostgreConnection -> [Int32] -> Property testAffectedRows c is = QM.monadicIO $ do   res <- QM.run $ withTransaction c $ do-    runRaw c "drop table if exists table1"-    runRaw c "create table table1 (val bigint)"-    runMany c "insert into table1(val) values (?)" $ map ((:[]) . toSql) is+    runRaw c "drop table if exists table2"+    runRaw c "create table table2 (val bigint)"+    runMany c "insert into table2(val) values (?)" $ map ((:[]) . toSql) is+    withStatement c "update table2 set val=10" $ \s -> do+      executeRaw s+      pgAffectedRows s -    s2 <- prepare c "update table1 set val=10"-    executeRaw s2-    res <- affectedRows s2-    finish s2-  -    return res   QM.stop $ res ?== (genericLength is)-           -testG2 :: PostgreConnection -> Test-testG2 c = testGroup "Auxiliary functions"-           [ testProperty "affectedRows" $ testAffectedRows c ] --stmtStatus :: PostgreConnection -> Assertion-stmtStatus c = do-  runRaw c "drop table table1"-  runRaw c "create table table1 (val bigint)" -- Just for postgre 9-  s <- prepare c "select * from table1"-  statementStatus s >>= (@?= StatementNew)-  executeRaw s-  statementStatus s >>= (@?= StatementExecuted)-  _ <- fetchRow s-  statementStatus s >>= (@?= StatementFetched)-  finish s-  statementStatus s >>= (@?= StatementFinished)-  reset s-  statementStatus s >>= (@?= StatementNew)--inTransactionStatus :: PostgreConnection -> Assertion-inTransactionStatus c = do-  inTransaction c >>= (@?= False)-  withTransaction c $ do-    inTransaction c >>= (@?= True)--connStatusGood :: PostgreConnection -> Assertion-connStatusGood c = connStatus c >>= (@?= ConnOK)--connClone :: PostgreConnection -> Assertion-connClone c = do-  newc <- clone c-  connStatus newc >>= (@?= ConnOK)-  withTransaction newc $ inTransaction c >>= (@?= False)-  withTransaction c $ inTransaction newc >>= (@?= False)-  disconnect newc-  connStatus newc >>= (@?= ConnDisconnected)--checkColumnNames :: PostgreConnection -> Assertion-checkColumnNames c = do-  withTransaction c $ do-    runRaw c "drop table if exists table1"-    runRaw c "create table table1 (val1 bigint, val2 bigint, val3 bigint)"-    s <- prepare c "select val1, val2, val3 from table1"-    executeRaw s-    getColumnNames s >>= (@?= ["val1", "val2", "val3"])-    getColumnsCount s >>= (@?= 3)-    finish s-  -testG3 :: PostgreConnection -> Test-testG3 c = testGroup "Fixed tests"-           [ testCase "Statement status" $ stmtStatus c-           , testCase "inTransaction return right value" $ inTransactionStatus c-           , testCase "Connection status is good" $ connStatusGood c-           , testCase "Connection clone works" $ connClone c+pgTests :: PostgreConnection -> Test+pgTests c = testGroup "Auxiliary functions"+           [ testProperty "affectedRows" $ testAffectedRows c            , testCase "Check driver name" $ hdbiDriverName c @?= "postgresql"            , testCase "Check transaction support" $ dbTransactionSupport c @?= True-           , testCase "Check right column names" $ checkColumnNames c            ] ++fields :: TestFieldTypes+fields = TestFieldTypes+         { tfDecimal = "decimal(600,300)"+         , tfInteger = "decimal(300,0)"+         , tfDouble = "double precision"+         , tfText = "text"+         , tfBlob = "bytea"+         , tfBool = "boolean"+         , tfBitField = "varbit"+         , tfUUID = "uuid"+         , tfUTCTime = "timestamp with time zone"+         , tfLocalDate = "date"+         , tfLocalTimeOfDay = "time"+         , tfLocalTime = "timestamp without time zone"+         }++ main :: IO () main = do   a <- getArgs   case a of-    (conn:args) -> do-      c <- connectPostgreSQL $ TL.pack conn-      (flip defaultMainWithArgs) args [ testG1 c-                                      , testG2 c-                                      , testG3 c-                                      ]-      disconnect c+    (conn:args) -> bracket+                   (connectPostgreSQL $ TL.pack conn)+                   disconnect+                   $ \c -> (flip defaultMainWithArgs) args [ allTests fields c+                                                           ,pgTests c+                                                           ]      _ -> do       mapM_ putStrLn [ "Need at least one argument as connection string"