pg-entity 0.0.4.2 → 0.0.4.3
raw patch · 19 files changed
+284/−326 lines, 19 filesdep +envparsedep +postgresql-migrationdep −exceptionsdep −monad-controldep −postgresql-simple-migrationdep ~basedep ~bytestringdep ~resource-poolPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependencies added: envparse, postgresql-migration
Dependencies removed: exceptions, monad-control, postgresql-simple-migration, strict, tmp-postgres
Dependency ranges changed: base, bytestring, resource-pool, safe-exceptions, template-haskell
API changes (from Hackage documentation)
- Database.PostgreSQL.Entity.Internal.BlogPost: Author :: AuthorId -> Text -> UTCTime -> Author
- Database.PostgreSQL.Entity.Internal.BlogPost: AuthorId :: UUID -> AuthorId
- Database.PostgreSQL.Entity.Internal.BlogPost: BlogPost :: BlogPostId -> AuthorId -> UUIDList -> Text -> Text -> UTCTime -> BlogPost
- Database.PostgreSQL.Entity.Internal.BlogPost: BlogPostId :: UUID -> BlogPostId
- Database.PostgreSQL.Entity.Internal.BlogPost: Tags :: Text -> [Text] -> Tags
- Database.PostgreSQL.Entity.Internal.BlogPost: UUIDList :: Vector UUID -> UUIDList
- Database.PostgreSQL.Entity.Internal.BlogPost: [$sel:authorId:Author] :: Author -> AuthorId
- Database.PostgreSQL.Entity.Internal.BlogPost: [$sel:authorId:BlogPost] :: BlogPost -> AuthorId
- Database.PostgreSQL.Entity.Internal.BlogPost: [$sel:blogPostId:BlogPost] :: BlogPost -> BlogPostId
- Database.PostgreSQL.Entity.Internal.BlogPost: [$sel:category:Tags] :: Tags -> Text
- Database.PostgreSQL.Entity.Internal.BlogPost: [$sel:content:BlogPost] :: BlogPost -> Text
- Database.PostgreSQL.Entity.Internal.BlogPost: [$sel:createdAt:Author] :: Author -> UTCTime
- Database.PostgreSQL.Entity.Internal.BlogPost: [$sel:createdAt:BlogPost] :: BlogPost -> UTCTime
- Database.PostgreSQL.Entity.Internal.BlogPost: [$sel:getAuthorId:AuthorId] :: AuthorId -> UUID
- Database.PostgreSQL.Entity.Internal.BlogPost: [$sel:getBlogPostId:BlogPostId] :: BlogPostId -> UUID
- Database.PostgreSQL.Entity.Internal.BlogPost: [$sel:getUUIDList:UUIDList] :: UUIDList -> Vector UUID
- Database.PostgreSQL.Entity.Internal.BlogPost: [$sel:labels:Tags] :: Tags -> [Text]
- Database.PostgreSQL.Entity.Internal.BlogPost: [$sel:name:Author] :: Author -> Text
- Database.PostgreSQL.Entity.Internal.BlogPost: [$sel:title:BlogPost] :: BlogPost -> Text
- Database.PostgreSQL.Entity.Internal.BlogPost: [$sel:uuidList:BlogPost] :: BlogPost -> UUIDList
- Database.PostgreSQL.Entity.Internal.BlogPost: bulkInsertAuthors :: [Author] -> DBT IO ()
- Database.PostgreSQL.Entity.Internal.BlogPost: bulkInsertBlogPosts :: [BlogPost] -> DBT IO ()
- Database.PostgreSQL.Entity.Internal.BlogPost: data Author
- Database.PostgreSQL.Entity.Internal.BlogPost: data BlogPost
- Database.PostgreSQL.Entity.Internal.BlogPost: data Tags
- Database.PostgreSQL.Entity.Internal.BlogPost: insertAuthor :: Author -> DBT IO ()
- Database.PostgreSQL.Entity.Internal.BlogPost: insertBlogPost :: BlogPost -> DBT IO ()
- Database.PostgreSQL.Entity.Internal.BlogPost: instance Database.PostgreSQL.Entity.Types.Entity Database.PostgreSQL.Entity.Internal.BlogPost.Author
- Database.PostgreSQL.Entity.Internal.BlogPost: instance Database.PostgreSQL.Entity.Types.Entity Database.PostgreSQL.Entity.Internal.BlogPost.BlogPost
- Database.PostgreSQL.Entity.Internal.BlogPost: instance Database.PostgreSQL.Entity.Types.Entity Database.PostgreSQL.Entity.Internal.BlogPost.Tags
- Database.PostgreSQL.Entity.Internal.BlogPost: instance Database.PostgreSQL.Simple.FromField.FromField Database.PostgreSQL.Entity.Internal.BlogPost.AuthorId
- Database.PostgreSQL.Entity.Internal.BlogPost: instance Database.PostgreSQL.Simple.FromField.FromField Database.PostgreSQL.Entity.Internal.BlogPost.BlogPostId
- Database.PostgreSQL.Entity.Internal.BlogPost: instance Database.PostgreSQL.Simple.FromField.FromField Database.PostgreSQL.Entity.Internal.BlogPost.UUIDList
- Database.PostgreSQL.Entity.Internal.BlogPost: instance Database.PostgreSQL.Simple.FromRow.FromRow Database.PostgreSQL.Entity.Internal.BlogPost.Author
- Database.PostgreSQL.Entity.Internal.BlogPost: instance Database.PostgreSQL.Simple.FromRow.FromRow Database.PostgreSQL.Entity.Internal.BlogPost.BlogPost
- Database.PostgreSQL.Entity.Internal.BlogPost: instance Database.PostgreSQL.Simple.ToField.ToField Database.PostgreSQL.Entity.Internal.BlogPost.AuthorId
- Database.PostgreSQL.Entity.Internal.BlogPost: instance Database.PostgreSQL.Simple.ToField.ToField Database.PostgreSQL.Entity.Internal.BlogPost.BlogPostId
- Database.PostgreSQL.Entity.Internal.BlogPost: instance Database.PostgreSQL.Simple.ToField.ToField Database.PostgreSQL.Entity.Internal.BlogPost.UUIDList
- Database.PostgreSQL.Entity.Internal.BlogPost: instance Database.PostgreSQL.Simple.ToRow.ToRow Database.PostgreSQL.Entity.Internal.BlogPost.Author
- Database.PostgreSQL.Entity.Internal.BlogPost: instance Database.PostgreSQL.Simple.ToRow.ToRow Database.PostgreSQL.Entity.Internal.BlogPost.BlogPost
- Database.PostgreSQL.Entity.Internal.BlogPost: instance GHC.Classes.Eq Database.PostgreSQL.Entity.Internal.BlogPost.Author
- Database.PostgreSQL.Entity.Internal.BlogPost: instance GHC.Classes.Eq Database.PostgreSQL.Entity.Internal.BlogPost.AuthorId
- Database.PostgreSQL.Entity.Internal.BlogPost: instance GHC.Classes.Eq Database.PostgreSQL.Entity.Internal.BlogPost.BlogPost
- Database.PostgreSQL.Entity.Internal.BlogPost: instance GHC.Classes.Eq Database.PostgreSQL.Entity.Internal.BlogPost.BlogPostId
- Database.PostgreSQL.Entity.Internal.BlogPost: instance GHC.Classes.Eq Database.PostgreSQL.Entity.Internal.BlogPost.UUIDList
- Database.PostgreSQL.Entity.Internal.BlogPost: instance GHC.Classes.Ord Database.PostgreSQL.Entity.Internal.BlogPost.Author
- Database.PostgreSQL.Entity.Internal.BlogPost: instance GHC.Classes.Ord Database.PostgreSQL.Entity.Internal.BlogPost.AuthorId
- Database.PostgreSQL.Entity.Internal.BlogPost: instance GHC.Classes.Ord Database.PostgreSQL.Entity.Internal.BlogPost.BlogPost
- Database.PostgreSQL.Entity.Internal.BlogPost: instance GHC.Classes.Ord Database.PostgreSQL.Entity.Internal.BlogPost.BlogPostId
- Database.PostgreSQL.Entity.Internal.BlogPost: instance GHC.Classes.Ord Database.PostgreSQL.Entity.Internal.BlogPost.UUIDList
- Database.PostgreSQL.Entity.Internal.BlogPost: instance GHC.Generics.Generic Database.PostgreSQL.Entity.Internal.BlogPost.Author
- Database.PostgreSQL.Entity.Internal.BlogPost: instance GHC.Generics.Generic Database.PostgreSQL.Entity.Internal.BlogPost.BlogPost
- Database.PostgreSQL.Entity.Internal.BlogPost: instance GHC.Generics.Generic Database.PostgreSQL.Entity.Internal.BlogPost.UUIDList
- Database.PostgreSQL.Entity.Internal.BlogPost: instance GHC.Records.HasField x Database.PostgreSQL.Entity.Internal.BlogPost.Author a => GHC.OverloadedLabels.IsLabel x (Database.PostgreSQL.Entity.Internal.BlogPost.Author -> a)
- Database.PostgreSQL.Entity.Internal.BlogPost: instance GHC.Records.HasField x Database.PostgreSQL.Entity.Internal.BlogPost.BlogPost a => GHC.OverloadedLabels.IsLabel x (Database.PostgreSQL.Entity.Internal.BlogPost.BlogPost -> a)
- Database.PostgreSQL.Entity.Internal.BlogPost: instance GHC.Show.Show Database.PostgreSQL.Entity.Internal.BlogPost.Author
- Database.PostgreSQL.Entity.Internal.BlogPost: instance GHC.Show.Show Database.PostgreSQL.Entity.Internal.BlogPost.AuthorId
- Database.PostgreSQL.Entity.Internal.BlogPost: instance GHC.Show.Show Database.PostgreSQL.Entity.Internal.BlogPost.BlogPost
- Database.PostgreSQL.Entity.Internal.BlogPost: instance GHC.Show.Show Database.PostgreSQL.Entity.Internal.BlogPost.BlogPostId
- Database.PostgreSQL.Entity.Internal.BlogPost: instance GHC.Show.Show Database.PostgreSQL.Entity.Internal.BlogPost.UUIDList
- Database.PostgreSQL.Entity.Internal.BlogPost: newtype AuthorId
- Database.PostgreSQL.Entity.Internal.BlogPost: newtype BlogPostId
- Database.PostgreSQL.Entity.Internal.BlogPost: newtype UUIDList
- Database.PostgreSQL.Entity.Internal.BlogPost: upsertBlogPost :: BlogPost -> Vector Field -> DBT IO ()
- Database.PostgreSQL.Entity.Types: instance Data.Text.Display.Display Database.PostgreSQL.Entity.Types.SortKeyword
+ Database.PostgreSQL.Entity.Types: instance Data.Text.Display.Core.Display Database.PostgreSQL.Entity.Types.SortKeyword
Files
- CHANGELOG.md +6/−0
- README.md +2/−3
- docs/book/404.html +2/−16
- docs/book/ErrorsGuide.html +2/−16
- docs/book/Introduction.html +2/−16
- docs/book/Tutorial.html +2/−16
- docs/book/css/chrome.css +13/−6
- docs/book/index.html +2/−16
- docs/book/print.html +2/−16
- docs/src/Tutorial.hs +5/−5
- pg-entity.cabal +14/−17
- src/Database/PostgreSQL/Entity.hs +1/−1
- src/Database/PostgreSQL/Entity/Internal/BlogPost.hs +0/−154
- src/Database/PostgreSQL/Entity/Types.hs +15/−15
- test/BlogPost.hs +154/−0
- test/EntitySpec.hs +11/−11
- test/GenericsSpec.hs +1/−1
- test/Main.hs +4/−15
- test/Utils.hs +46/−2
CHANGELOG.md view
@@ -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)
README.md view
@@ -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
docs/book/404.html view
@@ -33,6 +33,7 @@ </head> <body>+ <div id="body-container"> <!-- Provide site root to javascript --> <script> var path_to_root = "";@@ -165,25 +166,9 @@ </div> - <!-- Livereload script (if served using the cli tool) -->- <script>- const wsProtocol = location.protocol === 'https:' ? 'wss:' : 'ws:';- const wsAddress = wsProtocol + "//" + location.host + "/" + "__livereload";- const socket = new WebSocket(wsAddress);- socket.onmessage = function (event) {- if (event.data === "reload") {- socket.close();- location.reload();- }- }; - window.onbeforeunload = function() {- socket.close();- }- </script> - <script> window.playground_copyable = true; </script>@@ -200,5 +185,6 @@ <!-- Custom JS scripts --> + </div> </body> </html>
docs/book/ErrorsGuide.html view
@@ -32,6 +32,7 @@ </head> <body>+ <div id="body-container"> <!-- Provide site root to javascript --> <script> var path_to_root = "";@@ -240,25 +241,9 @@ </div> - <!-- Livereload script (if served using the cli tool) -->- <script>- const wsProtocol = location.protocol === 'https:' ? 'wss:' : 'ws:';- const wsAddress = wsProtocol + "//" + location.host + "/" + "__livereload";- const socket = new WebSocket(wsAddress);- socket.onmessage = function (event) {- if (event.data === "reload") {- socket.close();- location.reload();- }- }; - window.onbeforeunload = function() {- socket.close();- }- </script> - <script> window.playground_copyable = true; </script>@@ -275,5 +260,6 @@ <!-- Custom JS scripts --> + </div> </body> </html>
docs/book/Introduction.html view
@@ -32,6 +32,7 @@ </head> <body>+ <div id="body-container"> <!-- Provide site root to javascript --> <script> var path_to_root = "";@@ -191,25 +192,9 @@ </div> - <!-- Livereload script (if served using the cli tool) -->- <script>- const wsProtocol = location.protocol === 'https:' ? 'wss:' : 'ws:';- const wsAddress = wsProtocol + "//" + location.host + "/" + "__livereload";- const socket = new WebSocket(wsAddress);- socket.onmessage = function (event) {- if (event.data === "reload") {- socket.close();- location.reload();- }- }; - window.onbeforeunload = function() {- socket.close();- }- </script> - <script> window.playground_copyable = true; </script>@@ -226,5 +211,6 @@ <!-- Custom JS scripts --> + </div> </body> </html>
docs/book/Tutorial.html view
@@ -32,6 +32,7 @@ </head> <body>+ <div id="body-container"> <!-- Provide site root to javascript --> <script> var path_to_root = "";@@ -367,25 +368,9 @@ </div> - <!-- Livereload script (if served using the cli tool) -->- <script>- const wsProtocol = location.protocol === 'https:' ? 'wss:' : 'ws:';- const wsAddress = wsProtocol + "//" + location.host + "/" + "__livereload";- const socket = new WebSocket(wsAddress);- socket.onmessage = function (event) {- if (event.data === "reload") {- socket.close();- location.reload();- }- }; - window.onbeforeunload = function() {- socket.close();- }- </script> - <script> window.playground_copyable = true; </script>@@ -402,5 +387,6 @@ <!-- Custom JS scripts --> + </div> </body> </html>
docs/book/css/chrome.css view
@@ -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 <meta name="viewport"> 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 */
docs/book/index.html view
@@ -32,6 +32,7 @@ </head> <body>+ <div id="body-container"> <!-- Provide site root to javascript --> <script> var path_to_root = "";@@ -191,25 +192,9 @@ </div> - <!-- Livereload script (if served using the cli tool) -->- <script>- const wsProtocol = location.protocol === 'https:' ? 'wss:' : 'ws:';- const wsAddress = wsProtocol + "//" + location.host + "/" + "__livereload";- const socket = new WebSocket(wsAddress);- socket.onmessage = function (event) {- if (event.data === "reload") {- socket.close();- location.reload();- }- }; - window.onbeforeunload = function() {- socket.close();- }- </script> - <script> window.playground_copyable = true; </script>@@ -226,5 +211,6 @@ <!-- Custom JS scripts --> + </div> </body> </html>
docs/book/print.html view
@@ -33,6 +33,7 @@ </head> <body>+ <div id="body-container"> <!-- Provide site root to javascript --> <script> var path_to_root = "";@@ -451,25 +452,9 @@ </div> - <!-- Livereload script (if served using the cli tool) -->- <script>- const wsProtocol = location.protocol === 'https:' ? 'wss:' : 'ws:';- const wsAddress = wsProtocol + "//" + location.host + "/" + "__livereload";- const socket = new WebSocket(wsAddress);- socket.onmessage = function (event) {- if (event.data === "reload") {- socket.close();- location.reload();- }- }; - window.onbeforeunload = function() {- socket.close();- }- </script> - <script> window.playground_copyable = true; </script>@@ -491,5 +476,6 @@ }); </script> + </div> </body> </html>
docs/src/Tutorial.hs view
@@ -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)
pg-entity.cabal view
@@ -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
src/Database/PostgreSQL/Entity.hs view
@@ -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 "
− src/Database/PostgreSQL/Entity/Internal/BlogPost.hs
@@ -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 |]- ]
src/Database/PostgreSQL/Entity/Types.hs view
@@ -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)
+ test/BlogPost.hs view
@@ -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 |]+ ]
test/EntitySpec.hs view
@@ -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 ()
test/GenericsSpec.hs view
@@ -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
test/Main.hs view
@@ -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{..}
test/Utils.hs view
@@ -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