diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,11 @@ # Revision history for Entity +## 0.0.4.3 -- 2023-06-26 +* Fix the URL of the tutorial +* Bump version bounds for `base`, `resource-pool` and `template-haskell` +* Bump supported minor GHC versions +* Internalise `Database.PostgreSQL.Entity.Internal.BlogPost` for the tests + ## 0.0.3.0 -- 2022-10-30 * Fix compilation with resource-pool <0.3 (#51) diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -37,7 +37,6 @@ * [Installation](#installation) * [Documentation](#documentation) - * [Usage](#usage) * [Escape hatches](#escape-hatches) * [Acknowledgements](#acknowledgements) @@ -61,7 +60,7 @@ ## Documentation -You will find the Tutorial [here][docs-url], and you will find below a short showcase of the library. +* [Tutorial][docs-url] This library aims to be thoroughly tested, by the means of Oleg Grenrus' [cabal-docspec][docspec] and more traditional tests for database roundtrips. @@ -100,7 +99,7 @@ [docs-url]: https://hackage.haskell.org/package/pg-entity/src/docs/book/index.html [docspec]: https://github.com/phadej/cabal-extras/blob/master/cabal-docspec/MANUAL.md [pg-transact-hspec]: https://github.com/jfischoff/pg-transact-hspec.git -[entity-blogpost-fretlink]: https://tech.fretlink.com/yet-another-unsafe-db-layer/ +[entity-blogpost-fretlink]: https://blog.clement.delafargue.name/posts/2020-09-23-yet-another-unsafe-db-layer.html [anorm-pg-entity]: https://github.com/CleverCloud/anorm-pg-entity [pg-simple]: https://hackage.haskell.org/package/postgresql-simple [pg-transact]: https://hackage.haskell.org/package/pg-transact diff --git a/docs/book/404.html b/docs/book/404.html --- a/docs/book/404.html +++ b/docs/book/404.html @@ -33,6 +33,7 @@ +
- @@ -200,5 +185,6 @@ +
diff --git a/docs/book/ErrorsGuide.html b/docs/book/ErrorsGuide.html --- a/docs/book/ErrorsGuide.html +++ b/docs/book/ErrorsGuide.html @@ -32,6 +32,7 @@ +
- @@ -275,5 +260,6 @@ +
diff --git a/docs/book/Introduction.html b/docs/book/Introduction.html --- a/docs/book/Introduction.html +++ b/docs/book/Introduction.html @@ -32,6 +32,7 @@ +
- @@ -226,5 +211,6 @@ +
diff --git a/docs/book/Tutorial.html b/docs/book/Tutorial.html --- a/docs/book/Tutorial.html +++ b/docs/book/Tutorial.html @@ -32,6 +32,7 @@ +
- @@ -402,5 +387,6 @@ +
diff --git a/docs/book/css/chrome.css b/docs/book/css/chrome.css --- a/docs/book/css/chrome.css +++ b/docs/book/css/chrome.css @@ -2,12 +2,6 @@ @import 'variables.css'; -::-webkit-scrollbar { - background: var(--bg); -} -::-webkit-scrollbar-thumb { - background: var(--scrollbar); -} html { scrollbar-color: var(--scrollbar) var(--bg); } @@ -16,6 +10,19 @@ a:visited, a > .hljs { color: var(--links); +} + +/* + body-container is necessary because mobile browsers don't seem to like + overflow-x on the body tag when there is a tag. +*/ +#body-container { + /* + This is used when the sidebar pushes the body content off the side of + the screen on small screens. Without it, dragging on mobile Safari + will want to reposition the viewport in a weird way. + */ + overflow-x: hidden; } /* Menu Bar */ diff --git a/docs/book/index.html b/docs/book/index.html --- a/docs/book/index.html +++ b/docs/book/index.html @@ -32,6 +32,7 @@ +
- @@ -226,5 +211,6 @@ +
diff --git a/docs/book/print.html b/docs/book/print.html --- a/docs/book/print.html +++ b/docs/book/print.html @@ -33,6 +33,7 @@ +
- @@ -491,5 +476,6 @@ }); +
diff --git a/docs/src/Tutorial.hs b/docs/src/Tutorial.hs --- a/docs/src/Tutorial.hs +++ b/docs/src/Tutorial.hs @@ -5,9 +5,9 @@ -- ### Setting up -- #### Language Extensions -- --- * `OverloadedLists` allow us to use the `[list]` syntax for datatypes other than List, like Vector. --- * `QuasiQuotes` enable us to write plain SQL and field names in a `[|quasi-quoter block|]`. --- * The Deriving extensions give us more powerful typeclass derivation. +-- * `OverloadedLists` allow us to use the `[list]` syntax for datatypes other than List, like Vector. +-- * `QuasiQuotes` enable us to write plain SQL and field names in a `[|quasi-quoter block|]`. +-- * The Deriving extensions give us more powerful typeclass derivation. {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -187,7 +187,7 @@ pure Author{name = authorName, authorId, createdAt} addAuthor - :: (MonadIO m) + :: MonadIO m => Pool Connection -> AuthorInfo -> m () @@ -198,7 +198,7 @@ -- And if you want to later select an `Author` based on its `AuthorId`: getAuthor - :: (MonadIO m) + :: MonadIO m => Pool Connection -> AuthorId -> m (Maybe Author) diff --git a/pg-entity.cabal b/pg-entity.cabal --- a/pg-entity.cabal +++ b/pg-entity.cabal @@ -3,10 +3,12 @@ synopsis: A pleasant PostgreSQL layer description: A PostgreSQL layer to safely expand your SQL queries with a lightweight eDSL. - Read the tutorial at https://tchoutri.github.io/pg-entity/Tutorial + Read the tutorial at https://hackage.haskell.org/package/pg-entity/src/docs/book/index.html -version: 0.0.4.2 -homepage: https://tchoutri.github.io/pg-entity +version: 0.0.4.3 +homepage: + https://hackage.haskell.org/package/pg-entity/src/docs/book/index.html + bug-reports: https://github.com/tchoutri/pg-entity/issues author: Théophile Choutri maintainer: Théophile Choutri @@ -14,7 +16,7 @@ license: MIT build-type: Simple tested-with: - GHC ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.5 || ==9.4.4 + GHC ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.8 || ==9.4.5 extra-source-files: CHANGELOG.md @@ -84,7 +86,7 @@ -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wno-unused-do-bind -Wno-deprecations -Wpartial-fields -Wredundant-constraints -fhide-source-paths - -funbox-strict-fields -fwrite-ide-info -hiedir=.hie -haddock + -funbox-strict-fields -Wunused-packages common common-rts-options ghc-options: -rtsopts -threaded -with-rtsopts=-N @@ -96,24 +98,20 @@ Database.PostgreSQL.Entity Database.PostgreSQL.Entity.DBT Database.PostgreSQL.Entity.Internal - Database.PostgreSQL.Entity.Internal.BlogPost Database.PostgreSQL.Entity.Internal.QQ Database.PostgreSQL.Entity.Internal.Unsafe Database.PostgreSQL.Entity.Types hs-source-dirs: src build-depends: - , base >=4.12 && <4.18.0 + , base >=4.12 && <5.0 , bytestring ^>=0.11 , colourista ^>=0.1 - , exceptions ^>=0.10 - , monad-control ^>=1.0 , parsec ^>=3.1 , pg-transact ^>=0.3 , postgresql-simple ^>=0.6 - , resource-pool ^>=0.3 - , safe-exceptions ^>=0.1 - , template-haskell >=2.15.0.0 && <2.19.0.0.0 + , resource-pool ^>=0.4 + , template-haskell >=2.15.0.0 && <2.22.0.0.0 , text ^>=2.0 , text-display ^>=0.0 , text-manipulate ^>=0.3 @@ -140,17 +138,14 @@ build-depends: , base - , containers , directory , literatex - , monad-control , mtl , pg-entity , pg-transact , postgresql-simple , resource-pool , shake - , strict , text , time , uuid @@ -162,6 +157,7 @@ type: exitcode-stdio-1.0 main-is: Main.hs other-modules: + BlogPost EntitySpec GenericsSpec Utils @@ -170,20 +166,21 @@ build-depends: , aeson , base + , bytestring , containers + , envparse , hedgehog , mtl , optics-core , pg-entity , pg-transact + , postgresql-migration ^>=0.2 , postgresql-simple - , postgresql-simple-migration ^>=0.1 , resource-pool , safe-exceptions , tasty , tasty-hunit , text , time - , tmp-postgres , uuid , vector diff --git a/src/Database/PostgreSQL/Entity.hs b/src/Database/PostgreSQL/Entity.hs --- a/src/Database/PostgreSQL/Entity.hs +++ b/src/Database/PostgreSQL/Entity.hs @@ -467,7 +467,7 @@ @since 0.0.1.0 -} -_innerJoin :: forall e. (Entity e) => Field -> Query +_innerJoin :: forall e. Entity e => Field -> Query _innerJoin f = textToQuery $ " INNER JOIN " diff --git a/src/Database/PostgreSQL/Entity/Internal/BlogPost.hs b/src/Database/PostgreSQL/Entity/Internal/BlogPost.hs deleted file mode 100644 --- a/src/Database/PostgreSQL/Entity/Internal/BlogPost.hs +++ /dev/null @@ -1,154 +0,0 @@ -{-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE StrictData #-} - -{-| - Module : Database.PostgreSQL.Entity.Internal.BlogPost - Copyright : © Clément Delafargue, 2018 - Théophile Choutri, 2021 - Koz Ross, 2021 - License : MIT - Maintainer : theophile@choutri.eu - Stability : stable - - Adapted from Clément Delafargue's [Yet Another Unsafe DB Layer](https://tech.fretlink.com/yet-another-unsafe-db-layer/) - article. - - The models described in this module are used throughout the library's tests and docspecs. --} -module Database.PostgreSQL.Entity.Internal.BlogPost where - -import Data.Text (Text) -import Data.Time (UTCTime) -import Data.UUID (UUID) -import Data.Vector (Vector) -import Database.PostgreSQL.Simple.FromField (FromField) -import Database.PostgreSQL.Simple.FromRow (FromRow (..)) -import Database.PostgreSQL.Simple.ToField (Action (..), ToField (..)) -import Database.PostgreSQL.Simple.ToRow (ToRow) -import Database.PostgreSQL.Transact (DBT) -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 (Field, insert, insertMany, upsert) -import Database.PostgreSQL.Entity.Internal.QQ (field) -import Database.PostgreSQL.Entity.Types (Entity (..), GenericEntity, PrimaryKey, TableName) - --- | Wrapper around the UUID type -newtype AuthorId = AuthorId {getAuthorId :: UUID} - deriving - (Eq, FromField, Ord, Show, ToField) - via UUID - --- | Author data-type -data Author = Author - { authorId :: AuthorId - , name :: Text - , createdAt :: UTCTime - } - deriving stock (Eq, Generic, Ord, Show) - deriving anyclass (FromRow, ToRow) - deriving - (Entity) - via (GenericEntity '[PrimaryKey "author_id", TableName "authors"] Author) - -instance HasField x Author a => IsLabel x (Author -> a) where - fromLabel = getField @x - --- | Wrapper around the UUID type -newtype BlogPostId = BlogPostId {getBlogPostId :: UUID} - deriving - (Eq, FromField, Ord, Show, ToField) - via UUID - -newtype UUIDList = UUIDList {getUUIDList :: Vector UUID} - deriving stock (Generic, Show) - deriving - (Eq, FromField, Ord) - via Vector UUID - -instance ToField UUIDList where - toField (UUIDList vec) = - if Vector.null vec - then Plain (byteString "'{}'") - else - Many $ - Plain (byteString "ARRAY[") - : (List.intersperse (Plain (char8 ',')) . fmap toField $ Vector.toList vec) - ++ [Plain (char8 ']')] - ++ [Plain (byteString " :: uuid[]")] - -{-| The BlogPost data-type. Look at its 'Entity' instance declaration for how to handle - a "uuid[]" PostgreSQL type. --} -data BlogPost = BlogPost - { blogPostId :: BlogPostId - -- ^ Primary key - , authorId :: AuthorId - -- ^ Foreign keys, for which we need an explicit type annotation - , uuidList :: UUIDList - -- ^ A type that will need an explicit type annotation in the schema - , title :: Text - , content :: Text - , createdAt :: UTCTime - } - deriving stock (Eq, Generic, Ord, Show) - deriving anyclass (FromRow, ToRow) - -instance HasField x BlogPost a => IsLabel x (BlogPost -> a) where - fromLabel = getField @x - -instance Entity BlogPost where - tableName = "blogposts" - primaryKey = [field| blogpost_id |] - fields = - [ [field| blogpost_id |] - , [field| author_id |] - , [field| uuid_list |] - , [field| title |] - , [field| content |] - , [field| created_at |] - ] - -{-| A specialisation of the 'Database.PostgreSQL.Entity.insert' function. - @insertBlogPost = insert \@BlogPost@ --} -insertBlogPost :: BlogPost -> DBT IO () -insertBlogPost = insert @BlogPost - -upsertBlogPost :: BlogPost -> Vector Field -> DBT IO () -upsertBlogPost = upsert @BlogPost - --- | A function to insert many blogposts at once. -bulkInsertBlogPosts :: [BlogPost] -> DBT IO () -bulkInsertBlogPosts = insertMany @BlogPost - -{-| A specialisation of the 'Database.PostgreSQL.Entity.insert function. - @insertAuthor = insert \@Author@ --} -insertAuthor :: Author -> DBT IO () -insertAuthor = insert @Author - --- - --- | A function to insert many authors at once. -bulkInsertAuthors :: [Author] -> DBT IO () -bulkInsertAuthors = insertMany @Author - -data Tags = Tags - { category :: Text - , labels :: [Text] - } - -instance Entity Tags where - tableName = "tags" - schema = Just "public" - primaryKey = [field| category |] - fields = - [ [field| category |] - , [field| labels |] - ] diff --git a/src/Database/PostgreSQL/Entity/Types.hs b/src/Database/PostgreSQL/Entity/Types.hs --- a/src/Database/PostgreSQL/Entity/Types.hs +++ b/src/Database/PostgreSQL/Entity/Types.hs @@ -87,7 +87,7 @@ class Entity e where -- | The name of the table in the PostgreSQL database. tableName :: Text - default tableName :: (GetTableName (Rep e)) => Text + default tableName :: GetTableName (Rep e) => Text tableName = getTableName @(Rep e) defaultEntityOptions -- | The name of the schema; will be appended to the table name: schema."tablename" @@ -96,7 +96,7 @@ -- | The name of the primary key for the table. primaryKey :: Field - default primaryKey :: (GetFields (Rep e)) => Field + default primaryKey :: GetFields (Rep e) => Field primaryKey = newPrimaryKey where primMod = primaryKeyModifiers defaultEntityOptions @@ -108,26 +108,26 @@ -- | The fields of the table. fields :: Vector Field - default fields :: (GetFields (Rep e)) => Vector Field + default fields :: GetFields (Rep e) => Vector Field fields = getField @(Rep e) defaultEntityOptions -- The sub-class that fetches the table name class GetTableName (e :: Type -> Type) where getTableName :: Options -> Text -instance (TypeError ('Text "You can't derive Entity for a void type")) => GetTableName V1 where +instance TypeError ('Text "You can't derive Entity for a void type") => GetTableName V1 where getTableName _opts = error "You can't derive Entity for a void type" -instance (TypeError ('Text "You can't derive Entity for a unit type")) => GetTableName U1 where +instance TypeError ('Text "You can't derive Entity for a unit type") => GetTableName U1 where getTableName _opts = error "You can't derive Entity for a unit type" -instance (TypeError ('Text "You can't derive Entity for a sum type")) => GetTableName (e :+: f) where +instance TypeError ('Text "You can't derive Entity for a sum type") => GetTableName (e :+: f) where getTableName _opts = error "You can't derive Entity for a sum type" -instance (TypeError ('Text "You can't derive an Entity for a type constructor's field")) => GetTableName (K1 i c) where +instance TypeError ('Text "You can't derive an Entity for a type constructor's field") => GetTableName (K1 i c) where getTableName _opts = error "You can't derive Entity for a type constructor's field" -instance (TypeError ('Text "You don't have to derive GetTableName for a product type")) => GetTableName (e :*: f) where +instance TypeError ('Text "You don't have to derive GetTableName for a product type") => GetTableName (e :*: f) where getTableName _opts = error "You don't have to derive GetTableName for a product type" instance GetTableName e => GetTableName (M1 C _1 e) where @@ -137,7 +137,7 @@ getTableName opts = getTableName @e opts instance - (KnownSymbol name) + KnownSymbol name => GetTableName (M1 D ('MetaData name _1 _2 _3) e) where getTableName Options{tableNameModifiers, fieldModifiers} = tableNameModifiers $ fieldModifiers $ T.pack $ symbolVal (Proxy :: Proxy name) @@ -146,16 +146,16 @@ class GetFields (e :: Type -> Type) where getField :: Options -> Vector Field -instance (TypeError ('Text "You can't derive Entity for a void type")) => GetFields V1 where +instance TypeError ('Text "You can't derive Entity for a void type") => GetFields V1 where getField _opts = error "You can't derive Entity for a void type" -instance (TypeError ('Text "You can't derive Entity for a unit type")) => GetFields U1 where +instance TypeError ('Text "You can't derive Entity for a unit type") => GetFields U1 where getField _opts = error "You can't derive Entity for a unit type" -instance (TypeError ('Text "You can't derive Entity for a sum type")) => GetFields (e :+: f) where +instance TypeError ('Text "You can't derive Entity for a sum type") => GetFields (e :+: f) where getField _opts = error "You can't derive Entity for a sum type" -instance (TypeError ('Text "You can't derive Entity for a a type constructor's field")) => GetFields (K1 i c) where +instance TypeError ('Text "You can't derive Entity for a a type constructor's field") => GetFields (K1 i c) where getField _opts = error "You can't derive Entity for a type constructor's field" instance (GetFields e, GetFields f) => GetFields (e :*: f) where @@ -167,7 +167,7 @@ instance GetFields e => GetFields (M1 D ('MetaData _1 _2 _3 _4) e) where getField opts = getField @e opts -instance (KnownSymbol name) => GetFields (M1 S ('MetaSel ('Just name) _1 _2 _3) _4) where +instance KnownSymbol name => GetFields (M1 S ('MetaSel ('Just name) _1 _2 _3) _4) where getField Options{fieldModifiers} = V.singleton $ Field fieldName' Nothing where fieldName' = fieldModifiers $ T.pack $ symbolVal (Proxy @name) @@ -267,7 +267,7 @@ instance (TextModifier x, TextModifier xs) => TextModifier (x ': xs) where getTextModifier = getTextModifier @xs . getTextModifier @x -instance (KnownSymbol prefix) => TextModifier (StripPrefix prefix) where +instance KnownSymbol prefix => TextModifier (StripPrefix prefix) where getTextModifier fld = fromMaybe fld (T.stripPrefix prefixToStrip fld) where prefixToStrip = T.pack $ symbolVal (Proxy @prefix) diff --git a/test/BlogPost.hs b/test/BlogPost.hs new file mode 100644 --- /dev/null +++ b/test/BlogPost.hs @@ -0,0 +1,154 @@ +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StrictData #-} + +{-| + Module : BlogPost + Copyright : © Clément Delafargue, 2018 + Théophile Choutri, 2021 + Koz Ross, 2021 + License : MIT + Maintainer : theophile@choutri.eu + Stability : stable + + Adapted from Clément Delafargue's [Yet Another Unsafe DB Layer](https://tech.fretlink.com/yet-another-unsafe-db-layer/) + article. + + The models described in this module are used throughout the library's tests and docspecs. +-} +module BlogPost where + +import Data.Text (Text) +import Data.Time (UTCTime) +import Data.UUID (UUID) +import Data.Vector (Vector) +import Database.PostgreSQL.Simple.FromField (FromField) +import Database.PostgreSQL.Simple.FromRow (FromRow (..)) +import Database.PostgreSQL.Simple.ToField (Action (..), ToField (..)) +import Database.PostgreSQL.Simple.ToRow (ToRow) +import Database.PostgreSQL.Transact (DBT) +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 (Field, insert, insertMany, upsert) +import Database.PostgreSQL.Entity.Internal.QQ (field) +import Database.PostgreSQL.Entity.Types (Entity (..), GenericEntity, PrimaryKey, TableName) + +-- | Wrapper around the UUID type +newtype AuthorId = AuthorId {getAuthorId :: UUID} + deriving + (Eq, FromField, Ord, Show, ToField) + via UUID + +-- | Author data-type +data Author = Author + { authorId :: AuthorId + , name :: Text + , createdAt :: UTCTime + } + deriving stock (Eq, Generic, Ord, Show) + deriving anyclass (FromRow, ToRow) + deriving + (Entity) + via (GenericEntity '[PrimaryKey "author_id", TableName "authors"] Author) + +instance HasField x Author a => IsLabel x (Author -> a) where + fromLabel = getField @x + +-- | Wrapper around the UUID type +newtype BlogPostId = BlogPostId {getBlogPostId :: UUID} + deriving + (Eq, FromField, Ord, Show, ToField) + via UUID + +newtype UUIDList = UUIDList {getUUIDList :: Vector UUID} + deriving stock (Generic, Show) + deriving + (Eq, FromField, Ord) + via Vector UUID + +instance ToField UUIDList where + toField (UUIDList vec) = + if Vector.null vec + then Plain (byteString "'{}'") + else + Many $ + Plain (byteString "ARRAY[") + : (List.intersperse (Plain (char8 ',')) . fmap toField $ Vector.toList vec) + ++ [Plain (char8 ']')] + ++ [Plain (byteString " :: uuid[]")] + +{-| The BlogPost data-type. Look at its 'Entity' instance declaration for how to handle + a "uuid[]" PostgreSQL type. +-} +data BlogPost = BlogPost + { blogPostId :: BlogPostId + -- ^ Primary key + , authorId :: AuthorId + -- ^ Foreign keys, for which we need an explicit type annotation + , uuidList :: UUIDList + -- ^ A type that will need an explicit type annotation in the schema + , title :: Text + , content :: Text + , createdAt :: UTCTime + } + deriving stock (Eq, Generic, Ord, Show) + deriving anyclass (FromRow, ToRow) + +instance HasField x BlogPost a => IsLabel x (BlogPost -> a) where + fromLabel = getField @x + +instance Entity BlogPost where + tableName = "blogposts" + primaryKey = [field| blogpost_id |] + fields = + [ [field| blogpost_id |] + , [field| author_id |] + , [field| uuid_list |] + , [field| title |] + , [field| content |] + , [field| created_at |] + ] + +{-| A specialisation of the 'Database.PostgreSQL.Entity.insert' function. + @insertBlogPost = insert \@BlogPost@ +-} +insertBlogPost :: BlogPost -> DBT IO () +insertBlogPost = insert @BlogPost + +upsertBlogPost :: BlogPost -> Vector Field -> DBT IO () +upsertBlogPost = upsert @BlogPost + +-- | A function to insert many blogposts at once. +bulkInsertBlogPosts :: [BlogPost] -> DBT IO () +bulkInsertBlogPosts = insertMany @BlogPost + +{-| A specialisation of the 'Database.PostgreSQL.Entity.insert function. + @insertAuthor = insert \@Author@ +-} +insertAuthor :: Author -> DBT IO () +insertAuthor = insert @Author + +-- + +-- | A function to insert many authors at once. +bulkInsertAuthors :: [Author] -> DBT IO () +bulkInsertAuthors = insertMany @Author + +data Tags = Tags + { category :: Text + , labels :: [Text] + } + +instance Entity Tags where + tableName = "tags" + schema = Just "public" + primaryKey = [field| category |] + fields = + [ [field| category |] + , [field| labels |] + ] diff --git a/test/EntitySpec.hs b/test/EntitySpec.hs --- a/test/EntitySpec.hs +++ b/test/EntitySpec.hs @@ -4,6 +4,16 @@ module EntitySpec where +import BlogPost + ( Author (..) + , AuthorId (..) + , BlogPost (..) + , bulkInsertAuthors + , bulkInsertBlogPosts + , insertAuthor + , insertBlogPost + , upsertBlogPost + ) import Control.Monad (void) import Control.Monad.IO.Class import Data.Text (Text) @@ -26,16 +36,6 @@ , _where ) import Database.PostgreSQL.Entity.DBT (QueryNature (..), query) -import Database.PostgreSQL.Entity.Internal.BlogPost - ( Author (..) - , AuthorId (..) - , BlogPost (..) - , bulkInsertAuthors - , bulkInsertBlogPosts - , insertAuthor - , insertBlogPost - , upsertBlogPost - ) import Database.PostgreSQL.Simple (Only (Only)) import Database.PostgreSQL.Transact (DBT) @@ -131,7 +131,7 @@ let q = _joinSelectWithFields @BlogPost @Author [[field| title |]] [[field| name |]] <> _where [[field| name |]] - result <- liftDB (query Select q (Only ("Hansi Kürsch" :: Text)) :: (MonadIO m) => DBT m (Vector (Text, Text))) + result <- liftDB (query Select q (Only ("Hansi Kürsch" :: Text)) :: MonadIO m => DBT m (Vector (Text, Text))) U.assertEqual [("The Script for my requiem", "Hansi Kürsch"), ("Mordred's Song", "Hansi Kürsch")] result changeAuthorName :: TestM () diff --git a/test/GenericsSpec.hs b/test/GenericsSpec.hs --- a/test/GenericsSpec.hs +++ b/test/GenericsSpec.hs @@ -3,6 +3,7 @@ module GenericsSpec where +import BlogPost import Data.Aeson import Data.Text import Data.Time @@ -10,7 +11,6 @@ import Data.Vector import Database.PostgreSQL.Entity import Database.PostgreSQL.Entity.Internal (getTableName) -import Database.PostgreSQL.Entity.Internal.BlogPost import Database.PostgreSQL.Entity.Internal.Unsafe (Field (Field)) import Database.PostgreSQL.Entity.Types import Database.PostgreSQL.Simple diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,8 +1,6 @@ module Main where -import Data.Pool (createPool, withResource) -import qualified Database.PostgreSQL.Simple as PG -import qualified Database.Postgres.Temp as Postgres.Temp +import Data.Pool (withResource) import qualified EntitySpec import qualified GenericsSpec import Optics.Core @@ -24,15 +22,6 @@ getTestEnvironment :: IO TestEnv getTestEnvironment = do - eitherDb <- Postgres.Temp.start - case eitherDb of - Right db -> do - pool <- - createPool - (PG.connectPostgreSQL $ Postgres.Temp.toConnectionString db) - PG.close - 1 - 100000000 - 50 - pure TestEnv{..} - Left _ -> error "meh" + TestConfig{..} <- retrieveTestEnv + pool <- mkPool connectionInfo 100 10 + pure TestEnv{..} diff --git a/test/Utils.hs b/test/Utils.hs --- a/test/Utils.hs +++ b/test/Utils.hs @@ -6,8 +6,10 @@ import Control.Exception.Safe import Control.Monad.IO.Class import Control.Monad.Reader +import Data.ByteString (ByteString) import Data.Kind import Data.Pool (Pool) +import qualified Data.Pool as Pool import Data.Text (Text) import Data.Time import Data.UUID (UUID) @@ -17,6 +19,7 @@ import Database.PostgreSQL.Entity.DBT (withPool) import Database.PostgreSQL.Simple (Connection, SqlError (..)) import Database.PostgreSQL.Transact +import Env import GHC.Generics import Hedgehog (MonadGen (..)) import qualified Hedgehog.Gen as H @@ -26,7 +29,8 @@ import qualified Test.Tasty as Test import qualified Test.Tasty.HUnit as Test -import Database.PostgreSQL.Entity.Internal.BlogPost +import BlogPost +import qualified Database.PostgreSQL.Simple as PG import Database.PostgreSQL.Simple.Migration newtype TestM (a :: Type) = TestM {getTestM :: ReaderT TestEnv IO a} @@ -34,9 +38,15 @@ data TestEnv = TestEnv { pool :: Pool Connection + , connectionInfo :: ByteString } deriving stock (Generic) +data TestConfig = TestConfig + { connectionInfo :: ByteString + } + deriving stock (Generic, Show, Eq) + liftDB :: DBT IO a -> TestM a liftDB comp = do env <- getTestEnv @@ -51,7 +61,7 @@ ) migrate :: Connection -> IO () -migrate conn = void $ runMigrations False conn [MigrationInitialization, MigrationDirectory "./test/migrations"] +migrate conn = void $ runMigrations conn defaultOptions [MigrationInitialization, MigrationDirectory "./test/migrations"] runTestM :: TestM a -> TestEnv -> IO a runTestM comp env = @@ -196,3 +206,37 @@ let blogPost = BlogPost{..} insertBlogPost blogPost pure blogPost + +retrieveTestEnv :: IO TestConfig +retrieveTestEnv = + Env.parse id parseTestConfig + +parseConnectionInfo :: Parser Error ByteString +parseConnectionInfo = + var str "DB_CONNSTRING" (help "libpq-compatible connection string") + +parseTestConfig :: Parser Error TestConfig +parseTestConfig = + TestConfig + <$> parseConnectionInfo + +testConfigToTestEnv :: TestConfig -> IO TestEnv +testConfigToTestEnv TestConfig{..} = do + let connectionTimeout = 100 + let maxResources = 10 + pool <- mkPool connectionInfo connectionTimeout maxResources + pure TestEnv{..} + +mkPool + :: ByteString -- Database access information + -> NominalDiffTime -- Allowed timeout + -> Int -- Number of connections + -> IO (Pool PG.Connection) +mkPool connectionInfo timeout' maxResources = + Pool.newPool $ + Pool.setNumStripes (Just 10) $ + Pool.defaultPoolConfig + (PG.connectPostgreSQL connectionInfo) + PG.close + (realToFrac timeout') + maxResources