{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE StandaloneDeriving #-} module Database.Beam.Postgres.Test.Marshal where import Database.Beam import Database.Beam.Backend.SQL import Database.Beam.Backend.SQL.BeamExtensions import Database.Beam.Migrate import Database.Beam.Migrate.Simple (autoMigrate) import Database.Beam.Postgres import Database.Beam.Postgres.Migrate (migrationBackend) import Database.Beam.Postgres.Test import Database.PostgreSQL.Simple (execute_) import Data.ByteString (ByteString) import Data.Functor.Classes import Data.Int import qualified Data.Text as T import Data.Typeable import Data.UUID (UUID, fromWords) import Data.Word import qualified Data.Vector as Vector import qualified Hedgehog import Hedgehog ((===)) import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range import Test.Tasty import Test.Tasty.HUnit import Unsafe.Coerce textGen :: Hedgehog.Gen T.Text textGen = Gen.text (Range.constant 0 1000) $ Gen.filter (/= '\NUL') Gen.unicode uuidGen :: Hedgehog.Gen UUID uuidGen = fromWords <$> Gen.integral Range.constantBounded <*> Gen.integral Range.constantBounded <*> Gen.integral Range.constantBounded <*> Gen.integral Range.constantBounded pointGen :: Hedgehog.Gen PgPoint pointGen = PgPoint <$> Gen.double (Range.constant 0 1000) <*> Gen.double (Range.constant 0 1000) boxGen :: Hedgehog.Gen PgBox boxGen = do PgPoint x1 y1 <- pointGen PgPoint x2 y2 <- pointGen pure (PgBox (PgPoint (min x1 x2) (min y1 y2)) (PgPoint (max x1 x2) (max y1 y2))) arrayGen :: Hedgehog.Gen a -> Hedgehog.Gen (Vector.Vector a) arrayGen = fmap Vector.fromList . Gen.list (Range.linear 0 5) -- small arrays == quick tests boxCmp :: PgBox -> PgBox -> Bool boxCmp (PgBox a1 b1) (PgBox a2 b2) = (a1 `ptCmp` a2 && b1 `ptCmp` b2) || (a1 `ptCmp` b2 && b1 `ptCmp` a2) ptCmp :: PgPoint -> PgPoint -> Bool ptCmp (PgPoint x1 y1) (PgPoint x2 y2) = x1 `dblCmp` x2 && y1 `dblCmp` y2 dblCmp :: Double -> Double -> Bool dblCmp x y = let ulp = abs ((unsafeCoerce x :: Int64) - (unsafeCoerce y :: Int64)) in ulp < 50 tests :: IO ByteString -> TestTree tests postgresConn = testGroup "Postgres Marshaling tests" [ marshalTest Gen.bool postgresConn , marshalTest (Gen.integral (Range.constantBounded @Int16)) postgresConn , marshalTest (Gen.integral (Range.constantBounded @Int32)) postgresConn , marshalTest (Gen.integral (Range.constantBounded @Int64)) postgresConn , marshalTest (Gen.integral (Range.constantBounded @Word16)) postgresConn , marshalTest (Gen.integral (Range.constantBounded @Word32)) postgresConn , marshalTest (Gen.integral (Range.constantBounded @Word64)) postgresConn , marshalTest textGen postgresConn , marshalTest uuidGen postgresConn , marshalTest' (\a b -> Hedgehog.assert (ptCmp a b)) pointGen postgresConn , marshalTest' (\a b -> Hedgehog.assert (boxCmp a b)) boxGen postgresConn , marshalTest (Gen.maybe Gen.bool) postgresConn , marshalTest (Gen.maybe (Gen.integral (Range.constantBounded @Int16))) postgresConn , marshalTest (Gen.maybe (Gen.integral (Range.constantBounded @Int32))) postgresConn , marshalTest (Gen.maybe (Gen.integral (Range.constantBounded @Int64))) postgresConn , marshalTest (Gen.maybe (Gen.integral (Range.constantBounded @Word16))) postgresConn , marshalTest (Gen.maybe (Gen.integral (Range.constantBounded @Word32))) postgresConn , marshalTest (Gen.maybe (Gen.integral (Range.constantBounded @Word64))) postgresConn , marshalTest (Gen.maybe textGen) postgresConn , marshalTest (Gen.maybe uuidGen) postgresConn , marshalTest' (\a b -> Hedgehog.assert (liftEq ptCmp a b)) (Gen.maybe pointGen) postgresConn , marshalTest' (\a b -> Hedgehog.assert (liftEq boxCmp a b)) (Gen.maybe boxGen) postgresConn -- Arrays -- -- Testing lots of element types for arrays is important, because -- the mapping between array Oid and element Oid is not type -- safe, and hence error-prone. , marshalTest (arrayGen textGen) postgresConn , marshalTest (arrayGen (Gen.double (Range.exponentialFloat 0 1e40))) postgresConn , marshalTest (arrayGen ((Gen.integral (Range.constantBounded @Int16)))) postgresConn , marshalTest (arrayGen ((Gen.integral (Range.constantBounded @Int32)))) postgresConn , marshalTest (arrayGen ((Gen.integral (Range.constantBounded @Int64)))) postgresConn , marshalTest (Gen.maybe (arrayGen textGen)) postgresConn , marshalTest (Gen.maybe (arrayGen (Gen.double (Range.exponentialFloat 0 1e40)))) postgresConn , marshalTest (Gen.maybe (arrayGen ((Gen.integral (Range.constantBounded @Int16))))) postgresConn , marshalTest (Gen.maybe (arrayGen ((Gen.integral (Range.constantBounded @Int32))))) postgresConn , marshalTest (Gen.maybe (arrayGen ((Gen.integral (Range.constantBounded @Int64))))) postgresConn , marshalTest (Gen.double (Range.exponentialFloat 0 1e40)) postgresConn -- , marshalTest (Gen.integral (Range.constantBounded @Int)) postgresConn -- , marshalTest @Int8 postgresConn -- , marshalTest @Integer postgresConn -- , marshalTest @Word8 postgresConn -- , marshalTest @TL.Text postgresConn -- TODO MORE!!!! ] data MarshalTable a f = MarshalTable { _marshalTableId :: C f (SqlSerial Int32) , _marshalTableEntry :: C f a } deriving (Generic) instance Beamable (MarshalTable a) instance Typeable a => Table (MarshalTable a) where data PrimaryKey (MarshalTable a) f = MarshalTableKey (C f (SqlSerial Int32)) deriving (Generic, Beamable) primaryKey = MarshalTableKey . _marshalTableId data MarshalDb a entity = MarshalDb { _marshalTbl :: entity (TableEntity (MarshalTable a)) } deriving (Generic) instance Typeable a => Database Postgres (MarshalDb a) marshalTest :: forall a . ( Typeable a, Eq a, Show a , BeamSqlBackendSupportsDataType Postgres a , HasDefaultSqlDataType Postgres a , HasNullableConstraint (NullableStatus a) Postgres ) => Hedgehog.Gen a -> IO ByteString -> TestTree marshalTest = marshalTest' (===) marshalTest' :: forall a . ( Typeable a, Show a , BeamSqlBackendSupportsDataType Postgres a , HasDefaultSqlDataType Postgres a , HasNullableConstraint (NullableStatus a) Postgres ) => (forall m. (Hedgehog.MonadTest m, HasCallStack) => a -> a -> m ()) -> Hedgehog.Gen a -> IO ByteString -> TestTree marshalTest' cmp gen postgresConn = testCase ("Can marshal " ++ show (typeRep (Proxy @a))) $ withTestPostgres ("db_marshal_" <> show (typeRepFingerprint (typeRep (Proxy @a)))) postgresConn $ \conn -> do let marshalDbSettings = defaultMigratableDbSettings @Postgres @(MarshalDb a) marshalDb = unCheckDatabase marshalDbSettings runBeamPostgres conn $ do autoMigrate migrationBackend marshalDbSettings putStrLn "\n" passes <- Hedgehog.check . Hedgehog.property $ do a <- Hedgehog.forAll gen [MarshalTable rowId v] <- liftIO . runBeamPostgres conn $ runInsertReturningList $ insert (_marshalTbl marshalDb) $ insertExpressions [ MarshalTable default_ (val_ a) ] v `cmp` a Just (MarshalTable _ v') <- liftIO . runBeamPostgres conn $ runSelectReturningOne (lookup_ (_marshalTbl marshalDb) (MarshalTableKey rowId)) v' `cmp` a assertBool "Hedgehog test failed" passes