From 7a3100f79072b6a6a4a25033216fd1105d539333 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9ophile=20Choutri?= Date: Fri, 19 Jan 2024 12:15:07 +0100 Subject: [PATCH] Revamp doctest --- .github/workflows/ci.yml | 5 +- Makefile | 3 + src/Database/PostgreSQL/Entity.hs | 99 ++++++++++++------- src/Database/PostgreSQL/Entity/Internal.hs | 84 +++++++++++++--- src/Database/PostgreSQL/Entity/Internal/QQ.hs | 4 +- 5 files changed, 143 insertions(+), 52 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 68aef5c..71917ec 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -72,7 +72,6 @@ jobs: touch ~/.pgpass chmod 0600 ~/.pgpass echo "${FLORA_DB_HOST}:${FLORA_DB_PORT}:${FLORA_DB_DATABASE}:${FLORA_DB_USER}:${FLORA_DB_PASSWORD}" > .pgpass - cabal freeze - name: Cache uses: actions/cache@v3 @@ -85,8 +84,12 @@ jobs: run: | echo "$HOME/.local/bin" >> $GITHUB_PATH make build + cabal install doctest cabal install postgresql-migration + - name: Doctests + run: | + make doctest - name: Test run: | source environment.sh diff --git a/Makefile b/Makefile index a03f0fd..42abb07 100644 --- a/Makefile +++ b/Makefile @@ -30,6 +30,9 @@ docs-build: ## Generate the documentation docs-serve: ## Start a web server to serve the documentation @cd docs; mdbook serve --open +doctest: ## Run the doctests + @cabal repl --with-ghc=doctest + db-create: ## Create the database @createdb -h $(DB_HOST) -p $(DB_PORT) -U $(DB_USER) $(DB_DATABASE) diff --git a/src/Database/PostgreSQL/Entity.hs b/src/Database/PostgreSQL/Entity.hs index 7f9525d..b345609 100644 --- a/src/Database/PostgreSQL/Entity.hs +++ b/src/Database/PostgreSQL/Entity.hs @@ -98,18 +98,47 @@ import Database.PostgreSQL.Entity.Internal import Database.PostgreSQL.Entity.Types {- $setup - >>> :set -XQuasiQuotes - >>> :set -XOverloadedStrings - >>> :set -XOverloadedLists - >>> :set -XTypeApplications - >>> import Database.PostgreSQL.Entity - >>> import Database.PostgreSQL.Entity.Types - >>> import Database.PostgreSQL.Entity.Internal - >>> import Database.PostgreSQL.Entity.Internal.BlogPost - >>> import Database.PostgreSQL.Entity.Internal.QQ - >>> import Database.PostgreSQL.Simple.Types (Query (..)) - >>> import Data.Vector (Vector) - >>> import qualified Data.Vector as V +>>> :set -XQuasiQuotes +>>> :set -XOverloadedStrings +>>> :set -XOverloadedLists +>>> :set -XTypeApplications +>>> import Database.PostgreSQL.Entity +>>> import Database.PostgreSQL.Entity.Types +>>> import Database.PostgreSQL.Entity.Internal +>>> import Database.PostgreSQL.Entity.Internal.QQ +>>> import Database.PostgreSQL.Simple.Types (Query (..)) +>>> import Data.Vector (Vector) +>>> import qualified Data.Vector as V +>>> import Data.Time (UTCTime) +>>> import GHC.Generics (Generic) +>>> :{ +>>> data Author = Author +>>> { authorId :: Int +>>> , name :: Text +>>> , createdAt :: UTCTime +>>> } +>>> deriving stock (Eq, Generic, Ord, Show) +>>> deriving anyclass (FromRow, ToRow) +>>> deriving +>>> (Entity) +>>> via (GenericEntity '[PrimaryKey "author_id", TableName "authors"] Author) +>>> +>>> data BlogPost = BlogPost +>>> { blogPostId :: Int +>>> -- ^ Primary key +>>> , authorId :: Int +>>> -- ^ Foreign keys, for which we need an explicit type annotation +>>> , intList :: Vector Int +>>> , title :: Text +>>> , content :: Text +>>> , createdAt :: UTCTime +>>> } +>>> deriving stock (Eq, Generic, Ord, Show) +>>> deriving anyclass (FromRow, ToRow) +>>> deriving +>>> (Entity) +>>> via (GenericEntity '[PrimaryKey "blog_post_id", TableName "blogposts"] BlogPost) +>>> :} -} {- $highlevel @@ -348,7 +377,7 @@ deleteByField fs values = void $ execute Delete (_deleteWhere @e fs) values __Examples__ >>> _select @BlogPost - "SELECT blogposts.\"blogpost_id\", blogposts.\"author_id\", blogposts.\"uuid_list\", blogposts.\"title\", blogposts.\"content\", blogposts.\"created_at\" FROM \"blogposts\"" + "SELECT blogposts.\"blog_post_id\", blogposts.\"author_id\", blogposts.\"int_list\", blogposts.\"title\", blogposts.\"content\", blogposts.\"created_at\" FROM \"blogposts\"" @since 0.0.1.0 -} @@ -359,8 +388,8 @@ _select = textToQuery $ "SELECT " <> expandQualifiedFields @e <> " FROM " <> get __Examples__ - >>> _selectWithFields @BlogPost [ [field| blogpost_id |], [field| created_at |] ] - "SELECT \"blogposts\".\"blogpost_id\", \"blogposts\".\"created_at\" FROM \"\"blogposts\"\"" + >>> _selectWithFields @BlogPost [ [field| blog_post_id |], [field| created_at |] ] + "SELECT \"blogposts\".\"blog_post_id\", \"blogposts\".\"created_at\" FROM \"blogposts\"" @since 0.0.1.0 -} @@ -379,11 +408,11 @@ _selectWithFields fs = textToQuery $ "SELECT " <> expandQualifiedFields' fs tn < __Examples__ - >>> _select @BlogPost <> _where [[field| blogpost_id |]] - "SELECT blogposts.\"blogpost_id\", blogposts.\"author_id\", blogposts.\"uuid_list\", blogposts.\"title\", blogposts.\"content\", blogposts.\"created_at\" FROM \"blogposts\" WHERE \"blogpost_id\" = ?" + >>> _select @BlogPost <> _where [[field| blog_post_id |]] + "SELECT blogposts.\"blog_post_id\", blogposts.\"author_id\", blogposts.\"int_list\", blogposts.\"title\", blogposts.\"content\", blogposts.\"created_at\" FROM \"blogposts\" WHERE \"blog_post_id\" = ?" - >>> _select @BlogPost <> _where [ [field| uuid_list |] ] - "SELECT blogposts.\"blogpost_id\", blogposts.\"author_id\", blogposts.\"uuid_list\", blogposts.\"title\", blogposts.\"content\", blogposts.\"created_at\" FROM \"blogposts\" WHERE \"uuid_list\" = ?" + >>> _select @BlogPost <> _where [ [field| int_list |] ] + "SELECT blogposts.\"blog_post_id\", blogposts.\"author_id\", blogposts.\"int_list\", blogposts.\"title\", blogposts.\"content\", blogposts.\"created_at\" FROM \"blogposts\" WHERE \"int_list\" = ?" @since 0.0.1.0 -} @@ -397,10 +426,10 @@ _where fs' = textToQuery $ " WHERE " <> clauseFields __Examples__ >>> _selectWhere @BlogPost [ [field| author_id |] ] - "SELECT blogposts.\"blogpost_id\", blogposts.\"author_id\", blogposts.\"uuid_list\", blogposts.\"title\", blogposts.\"content\", blogposts.\"created_at\" FROM \"blogposts\" WHERE \"author_id\" = ?" + "SELECT blogposts.\"blog_post_id\", blogposts.\"author_id\", blogposts.\"int_list\", blogposts.\"title\", blogposts.\"content\", blogposts.\"created_at\" FROM \"blogposts\" WHERE \"author_id\" = ?" >>> _selectWhere @BlogPost [ [field| author_id |], [field| title |]] - "SELECT blogposts.\"blogpost_id\", blogposts.\"author_id\", blogposts.\"uuid_list\", blogposts.\"title\", blogposts.\"content\", blogposts.\"created_at\" FROM \"blogposts\" WHERE \"author_id\" = ? AND \"title\" = ?" + "SELECT blogposts.\"blog_post_id\", blogposts.\"author_id\", blogposts.\"int_list\", blogposts.\"title\", blogposts.\"content\", blogposts.\"created_at\" FROM \"blogposts\" WHERE \"author_id\" = ? AND \"title\" = ?" @since 0.0.1.0 -} @@ -411,7 +440,7 @@ _selectWhere fs = _select @e <> _where fs r >>> _selectWhereNotNull @BlogPost [ [field| author_id |] ] - "SELECT blogposts.\"blogpost_id\", blogposts.\"author_id\", blogposts.\"uuid_list\", blogposts.\"title\", blogposts.\"content\", blogposts.\"created_at\" FROM \"blogposts\" WHERE \"author_id\" IS NOT NULL" + "SELECT blogposts.\"blog_post_id\", blogposts.\"author_id\", blogposts.\"int_list\", blogposts.\"title\", blogposts.\"content\", blogposts.\"created_at\" FROM \"blogposts\" WHERE \"author_id\" IS NOT NULL" @since 0.0.1.0 -} @@ -421,7 +450,7 @@ _selectWhereNotNull fs = _select @e <> textToQuery (" WHERE " <> isNotNull fs) {-| Produce a SELECT statement where the provided fields are checked for being null. >>> _selectWhereNull @BlogPost [ [field| author_id |] ] - "SELECT blogposts.\"blogpost_id\", blogposts.\"author_id\", blogposts.\"uuid_list\", blogposts.\"title\", blogposts.\"content\", blogposts.\"created_at\" FROM \"blogposts\" WHERE \"author_id\" IS NULL" + "SELECT blogposts.\"blog_post_id\", blogposts.\"author_id\", blogposts.\"int_list\", blogposts.\"title\", blogposts.\"content\", blogposts.\"created_at\" FROM \"blogposts\" WHERE \"author_id\" IS NULL" @since 0.0.1.0 -} @@ -431,7 +460,7 @@ _selectWhereNull fs = _select @e <> textToQuery (" WHERE " <> isNull fs) {-| Produce a SELECT statement where the given field is checked aginst the provided array of values . >>> _selectWhereIn @BlogPost [field| title |] [ "Unnamed", "Mordred's Song" ] - "SELECT blogposts.\"blogpost_id\", blogposts.\"author_id\", blogposts.\"uuid_list\", blogposts.\"title\", blogposts.\"content\", blogposts.\"created_at\" FROM \"blogposts\" WHERE \"title\" IN ('Unnamed', 'Mordred''s Song')" + "SELECT blogposts.\"blog_post_id\", blogposts.\"author_id\", blogposts.\"int_list\", blogposts.\"title\", blogposts.\"content\", blogposts.\"created_at\" FROM \"blogposts\" WHERE \"title\" IN ('Unnamed', 'Mordred''s Song')" @since 0.0.2.0 -} @@ -443,7 +472,7 @@ _selectWhereIn f values = _select @e <> textToQuery (" WHERE " <> isIn f values) __Examples__ >>> _joinSelect @BlogPost @Author - "SELECT blogposts.\"blogpost_id\", blogposts.\"author_id\", blogposts.\"uuid_list\", blogposts.\"title\", blogposts.\"content\", blogposts.\"created_at\", authors.\"author_id\", authors.\"name\", authors.\"created_at\" FROM \"blogposts\" INNER JOIN \"authors\" USING(author_id)" + "SELECT blogposts.\"blog_post_id\", blogposts.\"author_id\", blogposts.\"int_list\", blogposts.\"title\", blogposts.\"content\", blogposts.\"created_at\", authors.\"author_id\", authors.\"name\", authors.\"created_at\" FROM \"blogposts\" INNER JOIN \"authors\" USING(author_id)" @since 0.0.1.0 -} @@ -510,7 +539,7 @@ _joinSelectWithFields fs1 fs2 = __Examples__ >>> _joinSelectOneByField @BlogPost @Author [field| author_id |] [field| name |] :: Query - "SELECT blogposts.\"blogpost_id\", blogposts.\"author_id\", blogposts.\"uuid_list\", blogposts.\"title\", blogposts.\"content\", blogposts.\"created_at\" FROM \"blogposts\" INNER JOIN \"authors\" ON \"blogposts\".\"author_id\" = \"authors\".\"author_id\" WHERE authors.\"name\" = ?" + "SELECT blogposts.\"blog_post_id\", blogposts.\"author_id\", blogposts.\"int_list\", blogposts.\"title\", blogposts.\"content\", blogposts.\"created_at\" FROM \"blogposts\" INNER JOIN \"authors\" ON \"blogposts\".\"author_id\" = \"authors\".\"author_id\" WHERE authors.\"name\" = ?" @since 0.0.2.0 -} @@ -544,7 +573,7 @@ _joinSelectOneByField pivotField whereField = __Examples__ >>> _insert @BlogPost - "INSERT INTO \"blogposts\" (\"blogpost_id\", \"author_id\", \"uuid_list\", \"title\", \"content\", \"created_at\") VALUES (?, ?, ?, ?, ?, ?)" + "INSERT INTO \"blogposts\" (\"blog_post_id\", \"author_id\", \"int_list\", \"title\", \"content\", \"created_at\") VALUES (?, ?, ?, ?, ?, ?)" @since 0.0.1.0 -} @@ -558,14 +587,14 @@ _insert = textToQuery $ "INSERT INTO " <> getTableName @e <> " " <> fs <> " VALU __Examples__ - >>> _onConflictDoUpdate [[field| blogpost_id |]] [ [field| title |], [field| content |]] - " ON CONFLICT (blogpost_id) DO UPDATE SET title = EXCLUDED.title, content = EXCLUDED.content" + >>> _onConflictDoUpdate [[field| blog_post_id |]] [ [field| title |], [field| content |]] + " ON CONFLICT (blog_post_id) DO UPDATE SET title = EXCLUDED.title, content = EXCLUDED.content" - >>> _onConflictDoUpdate [[field| blogpost_id |], [field| author_id |]] [ [field| title |], [field| content |]] - " ON CONFLICT (blogpost_id, author_id) DO UPDATE SET title = EXCLUDED.title, content = EXCLUDED.content" + >>> _onConflictDoUpdate [[field| blog_post_id |], [field| author_id |]] [ [field| title |], [field| content |]] + " ON CONFLICT (blog_post_id, author_id) DO UPDATE SET title = EXCLUDED.title, content = EXCLUDED.content" - >>> _insert @BlogPost <> _onConflictDoUpdate [[field| blogpost_id |]] [ [field| title |], [field| content |]] - "INSERT INTO \"blogposts\" (\"blogpost_id\", \"author_id\", \"uuid_list\", \"title\", \"content\", \"created_at\") VALUES (?, ?, ?, ?, ?, ?) ON CONFLICT (blogpost_id) DO UPDATE SET title = EXCLUDED.title, content = EXCLUDED.content" + >>> _insert @BlogPost <> _onConflictDoUpdate [[field| blog_post_id |]] [ [field| title |], [field| content |]] + "INSERT INTO \"blogposts\" (\"blog_post_id\", \"author_id\", \"int_list\", \"title\", \"content\", \"created_at\") VALUES (?, ?, ?, ?, ?, ?) ON CONFLICT (blog_post_id) DO UPDATE SET title = EXCLUDED.title, content = EXCLUDED.content" @since 0.0.2.0 -} @@ -586,7 +615,7 @@ _onConflictDoUpdate conflictTarget fieldsToReplace = "UPDATE \"authors\" SET (\"name\", \"created_at\") = ROW(?, ?) WHERE \"author_id\" = ?" >>> _update @BlogPost - "UPDATE \"blogposts\" SET (\"author_id\", \"uuid_list\", \"title\", \"content\", \"created_at\") = ROW(?, ?, ?, ?, ?) WHERE \"blogpost_id\" = ?" + "UPDATE \"blogposts\" SET (\"author_id\", \"int_list\", \"title\", \"content\", \"created_at\") = ROW(?, ?, ?, ?, ?) WHERE \"blog_post_id\" = ?" @since 0.0.1.0 -} @@ -655,7 +684,7 @@ _updateFieldsBy fs' f = __Examples__ >>> _delete @BlogPost - "DELETE FROM \"blogposts\" WHERE \"blogpost_id\" = ?" + "DELETE FROM \"blogposts\" WHERE \"blog_post_id\" = ?" @since 0.0.1.0 -} diff --git a/src/Database/PostgreSQL/Entity/Internal.hs b/src/Database/PostgreSQL/Entity/Internal.hs index 1d1519d..b56d60d 100644 --- a/src/Database/PostgreSQL/Entity/Internal.hs +++ b/src/Database/PostgreSQL/Entity/Internal.hs @@ -53,14 +53,63 @@ import Database.PostgreSQL.Entity.Internal.Unsafe (Field (Field)) import Database.PostgreSQL.Entity.Types {- $setup - >>> :set -XQuasiQuotes - >>> :set -XOverloadedLists - >>> :set -XTypeApplications - >>> import Database.PostgreSQL.Entity - >>> import Database.PostgreSQL.Entity.Types - >>> import Database.PostgreSQL.Entity.Internal.BlogPost - >>> import Database.PostgreSQL.Entity.Internal.QQ - >>> import Database.PostgreSQL.Entity.Internal.Unsafe +>>> :set -XQuasiQuotes +>>> :set -XOverloadedStrings +>>> :set -XOverloadedLists +>>> :set -XTypeApplications +>>> import Database.PostgreSQL.Entity +>>> import Database.PostgreSQL.Simple.FromRow (FromRow(..)) +>>> import Database.PostgreSQL.Simple.ToRow +>>> import Database.PostgreSQL.Entity.Types +>>> import Database.PostgreSQL.Entity.Internal +>>> import Database.PostgreSQL.Entity.Internal.QQ +>>> import Database.PostgreSQL.Simple.Types (Query (..)) +>>> import Data.Vector (Vector) +>>> import qualified Data.Vector as V +>>> import Data.Time (UTCTime) +>>> import GHC.Generics (Generic) +>>> :{ +>>> data Author = Author +>>> { authorId :: Int +>>> , name :: Text +>>> , createdAt :: UTCTime +>>> } +>>> deriving stock (Eq, Generic, Ord, Show) +>>> deriving anyclass (FromRow, ToRow) +>>> deriving +>>> (Entity) +>>> via (GenericEntity '[PrimaryKey "author_id", TableName "authors"] Author) +>>> +>>> data BlogPost = BlogPost +>>> { blogPostId :: Int +>>> -- ^ Primary key +>>> , authorId :: Int +>>> -- ^ Foreign keys, for which we need an explicit type annotation +>>> , intList :: Vector Int +>>> , title :: Text +>>> , content :: Text +>>> , createdAt :: UTCTime +>>> } +>>> deriving stock (Eq, Generic, Ord, Show) +>>> deriving anyclass (FromRow, ToRow) +>>> deriving +>>> (Entity) +>>> via (GenericEntity '[PrimaryKey "blog_post_id", TableName "blogposts"] BlogPost) +>>> +>>> data Tags = Tags +>>> { category :: Text +>>> , labels :: [Text] +>>> } +>>> +>>> instance Entity Tags where +>>> tableName = "tags" +>>> schema = Just "public" +>>> primaryKey = [field| category |] +>>> fields = +>>> [ [field| category |] +>>> , [field| labels |] +>>> ] +>>> :} -} {-| Wrap the given text between parentheses @@ -147,7 +196,7 @@ getFieldName = quoteName . fieldName __Examples__ >>> expandFields @BlogPost - "\"blogpost_id\", \"author_id\", \"uuid_list\", \"title\", \"content\", \"created_at\"" + "\"blog_post_id\", \"author_id\", \"int_list\", \"title\", \"content\", \"created_at\"" @since 0.0.1.0 -} @@ -159,7 +208,7 @@ expandFields = V.foldl1' (\element acc -> element <> ", " <> acc) (getFieldName __Examples__ >>> expandQualifiedFields @BlogPost - "blogposts.\"blogpost_id\", blogposts.\"author_id\", blogposts.\"uuid_list\", blogposts.\"title\", blogposts.\"content\", blogposts.\"created_at\"" + "blogposts.\"blog_post_id\", blogposts.\"author_id\", blogposts.\"int_list\", blogposts.\"title\", blogposts.\"content\", blogposts.\"created_at\"" @since 0.0.1.0 -} @@ -173,7 +222,7 @@ expandQualifiedFields = expandQualifiedFields' (fields @e) prefixName __Examples__ >>> expandQualifiedFields' (fields @BlogPost) "legacy" - "legacy.\"blogpost_id\", legacy.\"author_id\", legacy.\"uuid_list\", legacy.\"title\", legacy.\"content\", legacy.\"created_at\"" + "legacy.\"blog_post_id\", legacy.\"author_id\", legacy.\"int_list\", legacy.\"title\", legacy.\"content\", legacy.\"created_at\"" @since 0.0.1.0 -} @@ -203,7 +252,7 @@ qualifyField f = (\(Field fName _) -> p <> "." <> quoteName fName) f __Examples__ >>> qualifyFields "legacy" (fields @BlogPost) - [Field "legacy.\"blogpost_id\"" Nothing,Field "legacy.\"author_id\"" Nothing,Field "legacy.\"uuid_list\"" Nothing,Field "legacy.\"title\"" Nothing,Field "legacy.\"content\"" Nothing,Field "legacy.\"created_at\"" Nothing] + [Field "legacy.\"blog_post_id\"" Nothing,Field "legacy.\"author_id\"" Nothing,Field "legacy.\"int_list\"" Nothing,Field "legacy.\"title\"" Nothing,Field "legacy.\"content\"" Nothing,Field "legacy.\"created_at\"" Nothing] @since 0.0.1.0 -} @@ -221,7 +270,7 @@ qualifyFields p fs = fmap (\(Field f t) -> Field (p <> "." <> quoteName f) t) fs "\"ids\" = ?" >>> fmap placeholder $ fields @BlogPost - ["\"blogpost_id\" = ?","\"author_id\" = ?","\"uuid_list\" = ?","\"title\" = ?","\"content\" = ?","\"created_at\" = ?"] + ["\"blog_post_id\" = ?","\"author_id\" = ?","\"int_list\" = ?","\"title\" = ?","\"content\" = ?","\"created_at\" = ?"] @since 0.0.1.0 -} @@ -293,13 +342,20 @@ isNull fs' = fold $ intercalateVector " AND " (fmap process fieldNames) fieldNames = fmap fieldName fs' process f = quoteName f <> " IS NULL" +{-| Produce an "IS (, , …, )" clause + +>>> isIn [field| colour |] [ "yellow", "blue", "magenta" ] +"\"colour\" IN ('yellow', 'blue', 'magenta')" + +@since 0.0.2.0 +-} isIn :: Field -> Vector Text -> Text isIn f values = process f <> " IN (" <> fold (intercalateVector ", " vals) <> ")" where vals = fmap literal values process f' = quoteName $ fieldName f' -{-| Since the 'Query' type has an 'IsString' instance, the process of converting from 'Text' to 'String' to 'Query' is +{-| Since the 'Query' type has an 'Data.String.IsString' instance, the process of converting from 'Text' to 'String' to 'Query' is factored into this function ⚠ This may be dangerous and an unregulated usage of this function may expose to you SQL injection attacks diff --git a/src/Database/PostgreSQL/Entity/Internal/QQ.hs b/src/Database/PostgreSQL/Entity/Internal/QQ.hs index dd9007b..c4c6ef5 100644 --- a/src/Database/PostgreSQL/Entity/Internal/QQ.hs +++ b/src/Database/PostgreSQL/Entity/Internal/QQ.hs @@ -27,8 +27,8 @@ import Text.Parsec (Parsec, anyChar, manyTill, parse, space, spaces, string, try > instance Entity BlogPost where > tableName = "blogposts" - > primaryKey = [field| blogpost_id |] - > fields = [ [field| blogpost_id |] + > primaryKey = [field| blog_post_id |] + > fields = [ [field| blog_post_id |] > , [field| author_id |] > , [field| uuid_list :: uuid[] |] -- ← This is where we specify an optional PostgreSQL type annotation > , [field| title |]