From bd70c876afa8b55f6d0f523819b548024d340bd3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9ophile=20Choutri?= Date: Tue, 7 Jun 2022 17:40:00 +0200 Subject: [PATCH] Add a guide section on arrays with type sigs --- .hlint.yaml | 2 + docs/src/Guides.md | 13 ++++++ .../PostgreSQL/Entity/Internal/BlogPost.hs | 6 +-- src/Database/PostgreSQL/Entity/Internal/QQ.hs | 2 +- test/EntitySpec.hs | 34 ++++++++++---- test/Main.hs | 14 +++++- test/Utils.hs | 46 +++++++++++++++++-- test/migrations/20210228194538_blogpost.sql | 5 ++ 8 files changed, 104 insertions(+), 18 deletions(-) diff --git a/.hlint.yaml b/.hlint.yaml index 17312c7..53987f6 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -1,3 +1,5 @@ - ignore: {name: "Eta reduce"} - ignore: {name: "Avoid lambda"} - ignore: {name: "Avoid lambda using `infix`"} +- ignore: {name: "Use newtype instead of data"} +- ignore: {name: "Use tuple-section"} diff --git a/docs/src/Guides.md b/docs/src/Guides.md index 68494c7..4f41f7d 100644 --- a/docs/src/Guides.md +++ b/docs/src/Guides.md @@ -59,4 +59,17 @@ getEntity key = do -- business logic component. ``` +## Arrays of items + +Sometimes we want a field to be an array of items, like UUIDs. For such inner types, PostreSQL asks of you to +provide an explicit type signature. The case of arrays is interesting because you need to adapt to the syntax +wanted by PostreSQL: + +* An empty array is `{}`; +* An array with elements is `ARRAY[item1, item2, …, itemN]` +* An array with elements and a type signature is `ARRAY[item1, item2, …, itemN]::uuid[]` + + + [MonadError]: https://hackage.haskell.org/package/mtl-2.2.2/docs/Control-Monad-Except.html#t:MonadError + diff --git a/src/Database/PostgreSQL/Entity/Internal/BlogPost.hs b/src/Database/PostgreSQL/Entity/Internal/BlogPost.hs index cb52959..b1a2654 100644 --- a/src/Database/PostgreSQL/Entity/Internal/BlogPost.hs +++ b/src/Database/PostgreSQL/Entity/Internal/BlogPost.hs @@ -17,10 +17,13 @@ -- The models described in this module are used throughout the library's tests and docspecs. module Database.PostgreSQL.Entity.Internal.BlogPost where +import Data.ByteString.Builder (byteString, char8) +import qualified Data.List as List import Data.Text (Text) import Data.Time (UTCTime) import Data.UUID (UUID) import Data.Vector (Vector) +import qualified Data.Vector as Vector import Database.PostgreSQL.Simple.FromField (FromField) import Database.PostgreSQL.Simple.FromRow (FromRow (..)) import Database.PostgreSQL.Simple.ToField (Action (..), ToField (..)) @@ -30,9 +33,6 @@ import GHC.Generics (Generic) import GHC.OverloadedLabels (IsLabel (..)) import GHC.Records (HasField (..)) -import Data.ByteString.Builder (byteString, char8) -import qualified Data.List as List -import qualified Data.Vector as Vector import Database.PostgreSQL.Entity (insert, insertMany) import Database.PostgreSQL.Entity.Internal.QQ (field) import Database.PostgreSQL.Entity.Types (Entity (..), GenericEntity, PrimaryKey, TableName) diff --git a/src/Database/PostgreSQL/Entity/Internal/QQ.hs b/src/Database/PostgreSQL/Entity/Internal/QQ.hs index 7c9ea23..c67b237 100644 --- a/src/Database/PostgreSQL/Entity/Internal/QQ.hs +++ b/src/Database/PostgreSQL/Entity/Internal/QQ.hs @@ -29,7 +29,7 @@ import Text.Parsec (Parsec, anyChar, manyTill, parse, space, spaces, string, try -- > primaryKey = [field| blogpost_id |] -- > fields = [ [field| blogpost_id |] -- > , [field| author_id |] --- > , [field| uuid_list :: uuid[] |] -- ← This is where we specify an optional PostgreSQL type annotation +-- > , [field| uuid_list |] -- ← We will use a newtype wrapper to alter the 'ToField' instance -- > , [field| title |] -- > , [field| content |] -- > , [field| created_at |] diff --git a/test/EntitySpec.hs b/test/EntitySpec.hs index 984f6e1..d2d3872 100644 --- a/test/EntitySpec.hs +++ b/test/EntitySpec.hs @@ -13,6 +13,8 @@ import qualified Data.Vector as V import Database.PostgreSQL.Entity ( delete , deleteByField + , insert + , insertMany , joinSelectOneByField , selectById , selectManyByField @@ -32,13 +34,15 @@ import Database.PostgreSQL.Entity.Internal.BlogPost , AuthorId (..) , BlogPost (..) , BlogPostId (..) + , UUIDList , bulkInsertAuthors , bulkInsertBlogPosts , insertAuthor , insertBlogPost ) import Database.PostgreSQL.Entity.Internal.QQ (field) -import Database.PostgreSQL.Simple (Connection, Only (Only)) +import Database.PostgreSQL.Entity.Types +import Database.PostgreSQL.Simple (Connection, FromRow, Only (Only), ToRow) import Database.PostgreSQL.Simple.Migration ( MigrationCommand (MigrationDirectory, MigrationInitialization) , runMigrations @@ -47,8 +51,11 @@ import Database.PostgreSQL.Transact (DBT) import qualified Data.Set as S import qualified Data.Set as Set +import Data.UUID (UUID) import Data.Vector (Vector) -import Database.PostgreSQL.Entity.Types +import GHC.Generics (Generic) +import qualified Hedgehog.Gen as H +import qualified Hedgehog.Range as Range import Optics.Core import Test.Tasty import Test.Tasty.HUnit @@ -69,6 +76,7 @@ spec = , testThis "SELECT ORDER BY yields the appropriate results" testSelectOrderBy , testThis "select blog posts by author's name" selectBlogpostsByAuthorName , testThis "Insert many blog posts" insertManyBlogPosts + , testThis "Insert many faulty entities" insertManyFaultyEntities ] selectBlogPostByTitle :: TestM () @@ -241,10 +249,20 @@ insertManyBlogPosts = do author2 <- randomAuthor randomAuthorTemplate{generateName = pure "Léana Garibaldi"} void $ liftDB $ bulkInsertAuthors [author1, author2] --- author <- liftDB $ instantiateRandomAuthor randomAuthorTemplate{generateName = pure "Léana Garibaldi"} --- blogPost1 <- randomBlogPost randomBlogPostTemplate{ generateAuthorId = pure (author ^. #authorId) } --- blogPost2 <- randomBlogPost randomBlogPostTemplate{ generateAuthorId = pure (author ^. #authorId) } + author <- liftDB $ instantiateRandomAuthor randomAuthorTemplate{generateName = pure "Léana Garibaldi"} + blogPost1 <- randomBlogPost randomBlogPostTemplate{generateAuthorId = pure (author ^. #authorId)} + blogPost2 <- randomBlogPost randomBlogPostTemplate{generateAuthorId = pure (author ^. #authorId)} + + void $ liftDB $ bulkInsertBlogPosts [blogPost1, blogPost2] + result <- liftDB $ joinSelectOneByField @BlogPost @Author [field| author_id |] [field| name |] (author ^. #name) + U.assertEqual (S.fromList [blogPost1, blogPost2]) (S.fromList $ V.toList result) + +insertManyFaultyEntities :: TestM () +insertManyFaultyEntities = do + entity1 <- H.sample genFaultyEntity + entity2 <- H.sample genFaultyEntity + entity3 <- H.sample genFaultyEntity + entity4 <- H.sample genFaultyEntity --- void $ liftDB $ bulkInsertBlogPosts [blogPost1, blogPost2] --- result <- liftDB $ joinSelectOneByField @BlogPost @Author [field| author_id |] [field| name |] (author ^. #name) --- U.assertEqual (S.fromList [blogPost1, blogPost2]) (S.fromList $ V.toList result) + liftDB $ insert @FaultyEntity entity1 + liftDB $ insertMany @FaultyEntity [entity2, entity3, entity4] diff --git a/test/Main.hs b/test/Main.hs index dfba9a6..cc8b832 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -2,7 +2,9 @@ module Main where import Data.Pool (createPool, withResource) import qualified Database.PostgreSQL.Simple as PG +import Database.Postgres.Temp (Config (..)) import qualified Database.Postgres.Temp as Postgres.Temp +import Database.Postgres.Temp.Internal import qualified EntitySpec import qualified GenericsSpec import Optics.Core @@ -24,7 +26,7 @@ specs = getTestEnvironment :: IO TestEnv getTestEnvironment = do - eitherDb <- Postgres.Temp.start + eitherDb <- Postgres.Temp.startConfig customConfig case eitherDb of Right db -> do pool <- @@ -36,3 +38,13 @@ getTestEnvironment = do 50 pure TestEnv{..} Left _ -> error "meh" + +customConfig :: Config +customConfig = + verboseConfig + { postgresConfigFile = + verbosePostgresConfig + <> [ ("log_connections", "off") + , ("log_disconnections", "off") + ] + } diff --git a/test/Utils.hs b/test/Utils.hs index 4ea4897..6e07cb8 100644 --- a/test/Utils.hs +++ b/test/Utils.hs @@ -1,8 +1,8 @@ {-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} -{-# HLINT ignore "Use newtype instead of data" #-} module Utils where import Control.Exception.Safe @@ -14,10 +14,10 @@ import Data.Text (Text) import Data.Time import Data.UUID (UUID) import qualified Data.UUID as UUID -import qualified Data.Vector as V +import qualified Data.Vector as Vector import Data.Word import Database.PostgreSQL.Entity.DBT (withPool) -import Database.PostgreSQL.Simple (Connection) +import Database.PostgreSQL.Simple (Connection, FromRow, ToRow) import Database.PostgreSQL.Transact import GHC.Generics import Hedgehog (MonadGen (..)) @@ -28,7 +28,9 @@ import Test.Tasty (TestTree) import qualified Test.Tasty as Test import qualified Test.Tasty.HUnit as Test +import Data.Vector (Vector) import Database.PostgreSQL.Entity.Internal.BlogPost +import Database.PostgreSQL.Entity.Types import Database.PostgreSQL.Simple.Migration newtype TestM (a :: Type) = TestM {getTestM :: ReaderT TestEnv IO a} @@ -82,7 +84,7 @@ genUUID = UUID.fromWords <$> genWord32 <*> genWord32 <*> genWord32 <*> genWord32 genWord32 = H.word32 (Range.constant minBound maxBound) genUUIDList :: MonadGen m => m UUIDList -genUUIDList = UUIDList . V.fromList <$> H.list (Range.linear 1 10) genUUID +genUUIDList = UUIDList . Vector.fromList <$> H.list (Range.linear 1 10) genUUID genUTCTime :: MonadGen m => m UTCTime genUTCTime = do @@ -191,3 +193,37 @@ instantiateRandomBlogPost RandomBlogPostTemplate{..} = do let blogPost = BlogPost{..} insertBlogPost blogPost pure blogPost + +-- + +data FaultyEntity = FaultyEntity + { field1 :: Vector UUID + } + deriving stock (Eq, Show, Generic) + deriving anyclass (FromRow, ToRow) + +instance Entity FaultyEntity where + tableName = "faulty_entity" + primaryKey = [field| field1 |] + fields = [[field| field1 :: uuid[] |]] + +genFaultyEntity :: MonadGen m => m FaultyEntity +genFaultyEntity = do + field1 <- Vector.fromList <$> H.list (Range.linear 1 3) genUUID + pure FaultyEntity{..} + +data GoodEntity = GoodEntity + { field2 :: UUIDList + } + deriving stock (Eq, Show, Generic) + deriving anyclass (FromRow, ToRow) + +instance Entity GoodEntity where + tableName = "faulty_entity" + primaryKey = [field| field2 |] + fields = [[field| field2 |]] + +genGoodEntity :: MonadGen m => m GoodEntity +genGoodEntity = do + field2 <- genUUIDList + pure GoodEntity{..} diff --git a/test/migrations/20210228194538_blogpost.sql b/test/migrations/20210228194538_blogpost.sql index 71de421..2b09dff 100644 --- a/test/migrations/20210228194538_blogpost.sql +++ b/test/migrations/20210228194538_blogpost.sql @@ -15,3 +15,8 @@ create table blogposts ( foreign key(author_id) references authors(author_id) ); + +create table faulty_entity ( + field1 uuid[] primary key, + field2 uuid[] +);