QuickCheck tests for existing codecs

postgres-wire.cabal

@@ -87,6 +87,8 @@ test-suite postgres-wire-test
                      , Fault
                      , Protocol
                      , Misc
+                     , Codecs.Runner
+                     , Codecs.QuickCheck
   build-depends:       base
                      , postgres-wire
                      , bytestring
@@ -95,6 +97,9 @@ test-suite postgres-wire-test
                      , socket
                      , async
                      , tasty-hunit
+                     , tasty-quickcheck
+                     , QuickCheck >= 2.9
+                     , tagged
   ghc-options:         -threaded -rtsopts -with-rtsopts=-N
   default-language:    Haskell2010
   default-extensions:  

stack.yaml

@@ -9,6 +9,11 @@ packages:
 extra-deps: 
     - socket-0.8.0.0
     - socket-unix-0.2.0.0
+# <<<<<<< HEAD
+# =======
+#     - store-core-0.3
+#     - QuickCheck-2.9.2
+# >>>>>>> QuickCheck tests for existing codecs
 
 # Override default flag values for local packages and extra-deps
 flags: {}

tests/Codecs/QuickCheck.hs

@@ -0,0 +1,80 @@
+module Codecs.QuickCheck where
+
+import Test.Tasty
+import Test.QuickCheck
+import Test.QuickCheck.Arbitrary
+import Test.QuickCheck.Monadic
+
+import qualified Data.ByteString as B
+import qualified Data.Vector as V
+
+import Database.PostgreSQL.Driver
+import Database.PostgreSQL.Protocol.DataRows
+import Database.PostgreSQL.Protocol.Types
+import Database.PostgreSQL.Protocol.Store.Encode
+import Database.PostgreSQL.Protocol.Store.Decode
+import qualified Database.PostgreSQL.Protocol.Codecs.Decoders as PD
+import qualified Database.PostgreSQL.Protocol.Codecs.Encoders as PE
+import qualified Database.PostgreSQL.Protocol.Codecs.PgTypes  as PGT
+import Connection
+import Codecs.Runner
+
+
+-- | Makes property that if here is a value then encoding and sending it 
+--  to PostgreSQL, and receiving back returns the same value.
+makeCodecProperty 
+    :: (Eq a, Arbitrary a )
+    => Connection 
+    -> Oid -> (a -> Encode) -> PD.FieldDecoder a 
+    -> a -> Property
+makeCodecProperty c oid encoder fd v = monadicIO $ do
+    let bs = runEncode $ encoder v
+        q = Query "SELECT $1" (V.fromList [(oid, Just bs)])
+                    Binary Binary AlwaysCache
+        decoder = PD.dataRowHeader *> PD.getNonNullable fd
+    r <- run $ do
+        sendBatchAndSync c [q]
+        dr <- readNextData c
+        waitReadyForQuery c
+        either (error . show) (pure . decodeOneRow decoder) dr
+
+    assert $ v == r
+
+-- | Makes Tasty test tree.
+mkCodecTest 
+    :: (Eq a, Arbitrary a, Show a) 
+    => TestName -> PGT.Oids -> (a -> Encode) -> PD.FieldDecoder a
+    -> TestTree
+mkCodecTest name oids encoder decoder = testPropertyConn name $ \c ->
+    makeCodecProperty c (PGT.oidType oids) encoder decoder
+
+testCodecsEncodeDecode :: TestTree
+testCodecsEncodeDecode = testGroup "Codecs property 'encode . decode = id'"
+    [ mkCodecTest "bool" PGT.bool PE.bool PD.bool
+    , mkCodecTest "bytea" PGT.bytea PE.bytea PD.bytea
+    , mkCodecTest "char" PGT.char PE.char PD.char
+    -- TODO instance
+    -- , mkCodecTest "date" PGT.date PE.date PD.date
+    , mkCodecTest "float4" PGT.float4 PE.float4 PD.float4
+    , mkCodecTest "float8" PGT.float8 PE.float8 PD.float8
+    , mkCodecTest "int2" PGT.int2 PE.int2 PD.int2
+    , mkCodecTest "int4" PGT.int4 PE.int4 PD.int4
+    , mkCodecTest "int8" PGT.int8 PE.int8 PD.int8
+    -- TODO intstance
+    -- , mkCodecTest "interval" PGT.interval PE.interval PD.interval
+    , mkCodecTest "json" PGT.json PE.bsJsonText PD.bsJsonText
+    , mkCodecTest "jsonb" PGT.jsonb PE.bsJsonBytes PD.bsJsonBytes
+    -- TODO
+    -- , mkCodecTest "numeric" PGT.numeric PE.numeric PD.numeric
+    , mkCodecTest "text" PGT.text PE.bsText PD.bsText
+    -- TODO make instance
+    -- , mkCodecTest "timestamp" PGT.timestamp PE.timestamp PD.timestamp
+    -- TODO make instance
+    -- , mkCodecTest "timestamptz" PGT.timestamptz PE.timestamptz PD.timestamptz
+    -- TODO make instance
+    -- , mkCodecTest "uuid" PGT.uuid PE.uuid PD.uuid
+    ]
+
+-- TODO right instance
+instance Arbitrary B.ByteString where
+    arbitrary = oneof [pure "1", pure "2"]

tests/Codecs/Runner.hs

@@ -0,0 +1,24 @@
+module Codecs.Runner where
+
+import Data.Typeable
+import Data.Tagged
+import Test.Tasty.QuickCheck
+import Test.Tasty.Providers
+import Test.Tasty.Options
+import qualified Test.QuickCheck as QC
+
+import Database.PostgreSQL.Driver
+import Connection
+
+newtype ConnQC = ConnQC (Connection -> QC.Property)
+  deriving Typeable
+
+-- | Create a 'Test' for a QuickCheck 'QC.Testable' property
+testPropertyConn :: QC.Testable a => TestName -> (Connection -> a) -> TestTree
+testPropertyConn name fprop = singleTest name . ConnQC $ QC.property . fprop 
+
+instance IsTest ConnQC where
+  testOptions = retag (testOptions :: Tagged QC [OptionDescription])
+
+  run opts (ConnQC f) yieldProgress = withConnection $ \c ->
+    run opts (QC $ f c) yieldProgress

tests/test.hs

@@ -5,11 +5,14 @@ import Driver
 import Fault
 import Misc
 
+import Codecs.QuickCheck
+
 main :: IO ()
 main = defaultMain $ testGroup "Postgres-wire"
     [ testProtocolMessages
     , testDriver
     , testFaults
     , testMisc
+    , testCodecsEncodeDecode
     ]