diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,30 @@ +# Changelog + +All notable changes to `poppy` are documented in this file. + +The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.1.0/), +and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0.html). + +Released in **lockstep** with `poppy-codegen`. See the [repository changelog](../CHANGELOG.md) +for the full 1.0 contract, 1.1 plans, and non-goals. + +## 1.0.0 — 2026-10-09 + +Stable Postgres runtime for Schema-generated Clients. + +- Public API is `Poppy` only. Generated Clients import `Poppy.Internal.Generated`. + Low-level `findMany` / builders / `Db (..)` are no longer re-exported from `Poppy`. +- Haddock on Client-facing exports. Guides: repository `docs/`. +- `--check-schema` / pool helpers: shipped code reads `DATABASE_URL` only; tests use + `TEST_DATABASE_URL`. +- Remove `Poppy.JoinChain` and `Poppy.Relation`. Ad-hoc joins are raw SQL. +- `load` and `loadWith` take `where_`, `orderBy_`, and `take_`. Include result types + follow the include shape (`skip` / `load` / `loadWith`). +- Nested writes are fields on `create` / `update`. `createNested` / `updateNested` are gone. + Write success values remain root `*Row` values. +- `updateWhere` updates by a `Where`. `findUniqueWhere`, `requireUniqueWhere`, and + `InvalidUniqueInput` are gone. + +## 0.1.0.0 — 2026-09-17 + +First release. Runtime for Schema-generated Clients: queries, writes, `Db`, and Postgres errors. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2023–2026 Henrik Nerdrum + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Henrik Nerdrum nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,5 @@ +# poppy + +The runtime library for [Poppy](https://github.com/hnerdrum/poppy), a Postgres ORM for Haskell. Your app imports `poppy` to query and write through the client that [`poppy-codegen`](https://github.com/hnerdrum/poppy/tree/main/poppy-codegen) generates from your schema. It also provides `applyMigrations`, which runs your hand-written `.sql` migrations before the app starts. + +The [repository README](https://github.com/hnerdrum/poppy#readme) shows the full setup, and the [guides](https://github.com/hnerdrum/poppy/tree/main/docs) cover the client API, writes, relations, raw SQL, and errors. diff --git a/include-fail/RecordUpdateAmbiguous.hs b/include-fail/RecordUpdateAmbiguous.hs new file mode 100644 --- /dev/null +++ b/include-fail/RecordUpdateAmbiguous.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NoFieldSelectors #-} + +module RecordUpdateAmbiguous where + +import Poppy (load, skip) +import Schema.Include.Book (BookInclude (..)) + +data Other = Other {chapters :: Int} + +updated = + nested {chapters = load} + where + nested = BookInclude {chapters = skip} diff --git a/include-fail/SkippedChapters.hs b/include-fail/SkippedChapters.hs new file mode 100644 --- /dev/null +++ b/include-fail/SkippedChapters.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedRecordDot #-} + +module SkippedChapters where + +import Poppy.Internal.Include (Skip) +import Schema.Chapter (ChapterRow) +import Schema.Include.Book (BookWith (..)) + +bad :: BookWith Skip -> [ChapterRow] +bad row = row.chapters diff --git a/include-fail/SkippedChaptersNoSelectors.hs b/include-fail/SkippedChaptersNoSelectors.hs new file mode 100644 --- /dev/null +++ b/include-fail/SkippedChaptersNoSelectors.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE NoFieldSelectors #-} + +module SkippedChaptersNoSelectors where + +import Poppy.Internal.Include (Skip) +import Schema.Chapter (ChapterRow) +import Schema.Include.Book (BookWith (..)) + +bad :: BookWith Skip -> [ChapterRow] +bad row = row.chapters diff --git a/include-fail/WrongChild.hs b/include-fail/WrongChild.hs new file mode 100644 --- /dev/null +++ b/include-fail/WrongChild.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE DuplicateRecordFields #-} + +module WrongChild where + +import Poppy (loadWith, skip) +import qualified Schema.Client.Shelf as Shelf +import Schema.Include.Shelf (ShelfInclude (..)) + +bad = + Shelf.findMany + Shelf.emptyQuery + { Shelf.include_ = + ShelfInclude + { books = loadWith (ShelfInclude {books = skip, tags = skip}), + tags = skip + } + } diff --git a/poppy.cabal b/poppy.cabal new file mode 100644 --- /dev/null +++ b/poppy.cabal @@ -0,0 +1,185 @@ +cabal-version: 1.18 + +-- This file has been generated from package.yaml by hpack version 0.38.3. +-- +-- see: https://github.com/sol/hpack + +name: poppy +version: 1.0.0 +synopsis: Postgres runtime for generated Poppy Clients +description: Runtime used by Clients generated by poppy-codegen. + Application code imports this package to query and write Postgres. +category: Database +stability: stable +homepage: https://github.com/hnerdrum/poppy#readme +bug-reports: https://github.com/hnerdrum/poppy/issues +author: Henrik Nerdrum +maintainer: henrik.nerdrum@gmail.com +copyright: 2023–2026 Henrik Nerdrum +license: BSD3 +license-file: LICENSE +build-type: Simple +tested-with: + GHC == 9.4.8, GHC == 9.10.3 +extra-source-files: + test/migrations/001-test-widget.sql + test/migrations/002-test-shelf-book.sql + test/migrations/003-test-chapter.sql + test/migrations/004-test-section.sql + test/migrations/005-test-tag.sql + test/migrations/006-test-author-post.sql + test/migrations/007-test-packet.sql + test/migrations/008-test-comment.sql + test/migrations/009-test-widget-name-unique.sql + include-fail/RecordUpdateAmbiguous.hs + include-fail/SkippedChapters.hs + include-fail/SkippedChaptersNoSelectors.hs + include-fail/WrongChild.hs + unique-fail/NonUniqueFilter.hs +extra-doc-files: + README.md + CHANGELOG.md + +source-repository head + type: git + location: https://github.com/hnerdrum/poppy + +library + exposed-modules: + Poppy + Poppy.Internal.Generated + Poppy.Internal.Column + Poppy.Internal.Core + Poppy.Internal.Db + Poppy.Internal.Delete + Poppy.Internal.Errors + Poppy.Internal.Group + Poppy.Internal.Include + Poppy.Internal.Insert + Poppy.Internal.Migrate + Poppy.Internal.Operations + Poppy.Internal.PG + Poppy.Internal.Query + Poppy.Internal.Select + Poppy.Internal.SelectIn + Poppy.Internal.Sql + Poppy.Internal.Update + Poppy.Internal.Where + other-modules: + Paths_poppy + hs-source-dirs: + src + default-extensions: + DuplicateRecordFields + NamedFieldPuns + OverloadedRecordDot + OverloadedStrings + TypeFamilies + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints + build-depends: + aeson >=2.0 && <2.3 + , base >=4.17 && <4.21 + , bytestring >=0.11 && <0.13 + , containers >=0.6 && <0.8 + , directory ==1.3.* + , filepath >=1.4 && <1.6 + , mtl >=2.2 && <2.4 + , postgresql-simple >=0.6 && <0.8 + , resource-pool ==0.4.* + , scientific >=0.3.4 && <0.4 + , text >=2.0 && <2.2 + , time >=1.12 && <1.15 + , uuid ==1.3.* + default-language: Haskell2010 + +test-suite poppy-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Poppy.AuthorFixtures + Poppy.BelongsToSpec + Poppy.ClientWriteSpec + Poppy.CommentSpec + Poppy.DbSpec + Poppy.EnumSpec + Poppy.ErrorsSpec + Poppy.GroupSpec + Poppy.IncludeFailSpec + Poppy.IncludeSpec + Poppy.IncludeUpdate + Poppy.MigrateSpec + Poppy.NestedWriteSpec + Poppy.OperationsSpec + Poppy.RawSpec + Poppy.ScalarSpec + Poppy.SelectSpec + Poppy.ShelfFixtures + Poppy.UniqueFailSpec + Poppy.WhereSpec + Poppy.WidgetFixtures + Schema.Article + Schema.Author + Schema.Book + Schema.Chapter + Schema.Client.Article + Schema.Client.Author + Schema.Client.Book + Schema.Client.Chapter + Schema.Client.Comment + Schema.Client.Editor + Schema.Client.Post + Schema.Client.Section + Schema.Client.Shelf + Schema.Client.Tag + Schema.Client.Widget + Schema.Comment + Schema.Editor + Schema.Include.Author + Schema.Include.Book + Schema.Include.Chapter + Schema.Include.Comment + Schema.Include.Editor + Schema.Include.Post + Schema.Include.Shelf + Schema.Packet + Schema.Post + Schema.PostStatus + Schema.Section + Schema.Shelf + Schema.Tag + Schema.Widget + Support.Assert + Support.TestDb + Support.TestMigrations + Paths_poppy + hs-source-dirs: + test + default-extensions: + AllowAmbiguousTypes + DuplicateRecordFields + LambdaCase + NamedFieldPuns + OverloadedRecordDot + OverloadedStrings + ScopedTypeVariables + TypeApplications + TypeFamilies + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N + build-depends: + aeson >=2.0 && <2.3 + , base >=4.17 && <4.21 + , bytestring >=0.11 && <0.13 + , containers >=0.6 && <0.8 + , directory ==1.3.* + , filepath >=1.4 && <1.6 + , hspec >=2.11 && <2.13 + , mtl >=2.2 && <2.4 + , poppy + , postgresql-simple >=0.6 && <0.8 + , process ==1.6.* + , resource-pool ==0.4.* + , scientific >=0.3.4 && <0.4 + , text >=2.0 && <2.2 + , time >=1.12 && <1.15 + , uuid ==1.3.* + default-language: Haskell2010 diff --git a/src/Poppy.hs b/src/Poppy.hs new file mode 100644 --- /dev/null +++ b/src/Poppy.hs @@ -0,0 +1,107 @@ +-- | Runtime used by generated Poppy Clients. +-- +-- Application code typically imports this module plus @Schema.Client.*@. +-- Guides: the repository @docs/@ directory. This module is the Haddock +-- entry point for @Db@, @ORMError@, query combinators, and @applyMigrations@. +-- +-- Generated @Schema.*@ modules import 'Poppy.Internal.Generated' instead. +module Poppy + ( -- * Connection + Db, + DbPool, + PoolConfig (..), + SqlLogger, + connect, + connectWith, + defaultPool, + closePool, + runDb, + transaction, + transactionEither, + withTransaction, + + -- * Errors + ORMError (..), + DatabaseErrorInfo (..), + DriverErrorKind (..), + + -- * Where + Where, + eq, + neq, + gt, + gte, + lt, + lte, + in_, + contains, + isNull, + and_, + or_, + not_, + + -- * Order + OrderBy, + asc, + desc, + + -- * Select / values + OmitSelect (..), + Picked (..), + NullableValue (..), + + -- * Includes + Load (..), + load, + loadWith, + skip, + + -- * Raw SQL + queryRaw, + executeRaw, + param, + catchDb, + + -- * Migrations + applyMigrations, + MigrateError (..), + ) +where + +import Poppy.Internal.Column () +import Poppy.Internal.Core (NullableValue (..)) +import Poppy.Internal.Db + ( Db, + DbPool, + PoolConfig (..), + SqlLogger, + closePool, + connect, + connectWith, + defaultPool, + runDb, + transaction, + transactionEither, + withTransaction, + ) +import Poppy.Internal.Errors (DatabaseErrorInfo (..), DriverErrorKind (..), ORMError (..)) +import Poppy.Internal.Include (Load (..), load, loadWith, skip) +import Poppy.Internal.Migrate (MigrateError (..), applyMigrations) +import Poppy.Internal.Query (OrderBy, asc, desc) +import Poppy.Internal.Select (OmitSelect (..), Picked (..)) +import Poppy.Internal.Sql (catchDb, executeRaw, param, queryRaw) +import Poppy.Internal.Where + ( Where, + and_, + contains, + eq, + gt, + gte, + in_, + isNull, + lt, + lte, + neq, + not_, + or_, + ) diff --git a/src/Poppy/Internal/Column.hs b/src/Poppy/Internal/Column.hs new file mode 100644 --- /dev/null +++ b/src/Poppy/Internal/Column.hs @@ -0,0 +1,45 @@ +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_HADDOCK hide #-} + +-- | 'Column' instances for Schema scalars (including @numeric@ / 'Data.Scientific.Scientific' and @jsonb@ / 'Data.Aeson.Value'). +module Poppy.Internal.Column + ( Column (..), + ) +where + +import Data.Aeson (Value) +import Data.Int (Int32, Int64) +import Data.Scientific (Scientific) +import Data.Text (Text) +import Data.Time (UTCTime) +import Data.UUID (UUID) +import Database.PostgreSQL.Simple.FromField () +import Database.PostgreSQL.Simple.ToField () +import Poppy.Internal.Core (Column (..)) + +instance Column UUID where + columnType = "uuid" + +instance Column Text where + columnType = "text" + +instance Column Int where + columnType = "integer" + +instance Column Int32 where + columnType = "integer" + +instance Column Int64 where + columnType = "bigint" + +instance Column Scientific where + columnType = "numeric" + +instance Column Value where + columnType = "jsonb" + +instance Column UTCTime where + columnType = "timestamp with time zone" + +instance Column Bool where + columnType = "boolean" diff --git a/src/Poppy/Internal/Core.hs b/src/Poppy/Internal/Core.hs new file mode 100644 --- /dev/null +++ b/src/Poppy/Internal/Core.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_HADDOCK hide #-} + +module Poppy.Internal.Core + ( Entity (..), + Column (..), + SqlType (..), + Field (..), + NullableValue (..), + PrimaryKeyType, + ) +where + +import Data.Text (Text) +import Database.PostgreSQL.Simple.FromField (FromField) +import Database.PostgreSQL.Simple.ToField (ToField) + +class SqlType a where + toSqlType :: Text + +class (FromField a, ToField a) => Column a where + columnType :: Text + +data Field table a = Field + { fieldName :: Text, + fieldColumn :: Text + } + +class Entity table where + tableName :: Text + primaryKey :: Field table (PrimaryKeyType table) + tableColumns :: [Text] + uniqueKeys :: [[Text]] + uniqueKeys = [[fieldColumn (primaryKey @table)]] + +type family PrimaryKeyType table + +-- | Three-way column input for nullable fields on create and update. +-- 'Omit' leaves the column out; 'Value' sets it; 'Null' sets SQL NULL. +data NullableValue a + = Omit + | Value a + | Null + deriving (Show, Eq) diff --git a/src/Poppy/Internal/Db.hs b/src/Poppy/Internal/Db.hs new file mode 100644 --- /dev/null +++ b/src/Poppy/Internal/Db.hs @@ -0,0 +1,141 @@ +{-# OPTIONS_HADDOCK hide #-} +-- | Connection pool, 'Db' monad, and SQL logging. +module Poppy.Internal.Db + ( Db (..), + DbPool (..), + DbEnv (..), + PoolConfig (..), + SqlLogger, + defaultPool, + connect, + connectWith, + closePool, + runDb, + withTransaction, + transaction, + transactionEither, + withConn, + dbIO, + logSql, + liftIO, + ) +where + +import Control.Exception (handle, throwIO) +import Control.Monad.IO.Class (MonadIO (..), liftIO) +import qualified Data.ByteString.Char8 as B8 +import Data.Pool (Pool, defaultPoolConfig, destroyAllResources, newPool, setNumStripes, withResource) +import Data.Text (Text) +import Database.PostgreSQL.Simple (Connection) +import qualified Database.PostgreSQL.Simple as PG +import Poppy.Internal.Errors (ORMError) + +-- | Assembled SQL only; bound parameters are not logged. +type SqlLogger = Text -> IO () + +-- | Connection pool and SQL logger. Bound parameters are never logged. +data PoolConfig = PoolConfig + { poolStripes :: Int, + poolMaxPerStripe :: Int, + poolIdleSeconds :: Double, + poolSqlLog :: SqlLogger + } + +-- | 4 stripes × 5 connections, 10s idle, no SQL log. +defaultPool :: PoolConfig +defaultPool = + PoolConfig + { poolStripes = 4, + poolMaxPerStripe = 5, + poolIdleSeconds = 10, + poolSqlLog = \_ -> pure () + } + +-- | Pool plus SQL logger. +data DbPool = DbPool + { unDbPool :: Pool Connection, + dbSqlLog :: SqlLogger + } + +data DbEnv = DbEnv + { dbConnection :: Connection, + dbLogSql :: SqlLogger + } + +-- | Postgres work on a pooled connection. +newtype Db a = Db {unDb :: DbEnv -> IO a} + +instance Functor Db where + fmap f (Db g) = Db (fmap f . g) + +instance Applicative Db where + pure x = Db (const (pure x)) + Db f <*> Db x = Db $ \env -> f env <*> x env + +instance Monad Db where + Db m >>= f = Db $ \env -> do + a <- m env + unDb (f a) env + +instance MonadIO Db where + liftIO io = Db (const io) + +dbIO :: (Connection -> IO a) -> Db a +dbIO action = Db $ \env -> action (dbConnection env) + +logSql :: Text -> Db () +logSql sql = Db $ \env -> dbLogSql env sql + +-- | Connect with 'defaultPool'. +connect :: String -> IO DbPool +connect = connectWith defaultPool + +-- | Connect with an explicit 'PoolConfig'. +connectWith :: PoolConfig -> String -> IO DbPool +connectWith config databaseUrl = do + let totalMaxConnections = poolStripes config * poolMaxPerStripe config + poolConfig = + setNumStripes (Just (poolStripes config)) $ + defaultPoolConfig + (PG.connectPostgreSQL $ B8.pack databaseUrl) + PG.close + (poolIdleSeconds config) + totalMaxConnections + pool <- newPool poolConfig + pure DbPool {unDbPool = pool, dbSqlLog = poolSqlLog config} + +-- | Destroy every connection in the pool. +closePool :: DbPool -> IO () +closePool (DbPool pool _) = destroyAllResources pool + +-- | Run a 'Db' action on one pooled connection. +runDb :: DbPool -> Db a -> IO a +runDb pool (Db action) = + withResource (unDbPool pool) $ \conn -> + action (DbEnv {dbConnection = conn, dbLogSql = dbSqlLog pool}) + +withConn :: DbPool -> (Connection -> IO a) -> IO a +withConn (DbPool pool _) = withResource pool + +withTransaction :: DbPool -> Db a -> IO a +withTransaction pool (Db action) = + withResource (unDbPool pool) $ \conn -> + let env = DbEnv {dbConnection = conn, dbLogSql = dbSqlLog pool} + in PG.withTransaction conn (action env) + +-- | Wrap an in-flight 'Db' action in @BEGIN@/@COMMIT@ (vs 'withTransaction', which takes a pool). +transaction :: Db a -> Db a +transaction (Db action) = Db $ \env -> + PG.withTransaction (dbConnection env) (action env) + +-- | Like 'transaction', but 'Left' also rolls back. @postgresql-simple@ only +-- undoes the transaction when the action throws; 'ORMError' is rethrown inside +-- the transaction and caught afterwards so callers still see 'Either'. +transactionEither :: Db (Either ORMError a) -> Db (Either ORMError a) +transactionEither (Db action) = Db $ \env -> + handle (pure . Left) $ + PG.withTransaction (dbConnection env) $ do + result <- action env + case result of + Left err -> throwIO err + Right val -> pure (Right val) diff --git a/src/Poppy/Internal/Delete.hs b/src/Poppy/Internal/Delete.hs new file mode 100644 --- /dev/null +++ b/src/Poppy/Internal/Delete.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -Wno-redundant-constraints #-} +{-# OPTIONS_HADDOCK hide #-} + +module Poppy.Internal.Delete + ( DeleteBuilder, + deleteWhere, + deleteMany, + deleteReturning, + whereDelete, + emptyDelete, + ) +where + +import Data.Text (Text) +import qualified Data.Text.Encoding as TE +import Database.PostgreSQL.Simple (Connection) +import qualified Database.PostgreSQL.Simple as PGSimple +import Database.PostgreSQL.Simple.FromRow (FromRow, fromRow) +import Database.PostgreSQL.Simple.ToField (Action) +import Database.PostgreSQL.Simple.Types (Query (..)) +import Poppy.Internal.Core (Entity (..)) +import Poppy.Internal.Db (Db, dbIO) +import Poppy.Internal.Errors (ORMError (..)) +import Poppy.Internal.Query (buildWhereClause) +import Poppy.Internal.Sql (catchSql, quoteIdent) +import Poppy.Internal.Where (Where, compileWhere) + +data DeleteBuilder table = DeleteBuilder + { dbTable :: Text, + dbWhere :: [Text], + dbWhereParams :: [Action] + } + +emptyDelete :: forall table. (Entity table) => DeleteBuilder table +emptyDelete = + DeleteBuilder + { dbTable = tableName @table, + dbWhere = [], + dbWhereParams = [] + } + +whereDelete :: Text -> [Action] -> DeleteBuilder table -> DeleteBuilder table +whereDelete condition params builder = + builder + { dbWhere = dbWhere builder ++ [condition], + dbWhereParams = dbWhereParams builder ++ params + } + +deleteWhere :: + forall table. + (Entity table) => + DeleteBuilder table -> + Db (Either ORMError Int) +deleteWhere builder + | null (dbWhere builder) = + pure (Left (EmptyWhere "DELETE requires a WHERE clause")) + | otherwise = dbIO $ \conn -> catchSql (runDeleteWhere conn builder) + +deleteMany :: + forall table. + (Entity table) => + Where table -> + Db (Either ORMError Int) +deleteMany clause = + let (sql, params) = compileWhere clause + builder = whereDelete sql params (emptyDelete @table) + in deleteWhere builder + +deleteReturning :: + forall table result. + (Entity table, FromRow result) => + DeleteBuilder table -> + Db (Either ORMError [result]) +deleteReturning builder + | null (dbWhere builder) = + pure (Left (EmptyWhere "DELETE requires a WHERE clause")) + | otherwise = dbIO $ \conn -> catchSql (runDeleteReturning conn builder) + +runDeleteWhere :: + Connection -> + DeleteBuilder table -> + IO Int +runDeleteWhere conn builder = do + let queryText = + "DELETE FROM " + <> quoteIdent (dbTable builder) + <> buildWhereClause (dbWhere builder) + query = Query (TE.encodeUtf8 queryText) + fromIntegral <$> PGSimple.execute conn query (dbWhereParams builder) + +runDeleteReturning :: + forall table result. + (FromRow result) => + Connection -> + DeleteBuilder table -> + IO [result] +runDeleteReturning conn builder = do + let queryText = + "DELETE FROM " + <> quoteIdent (dbTable builder) + <> buildWhereClause (dbWhere builder) + <> " RETURNING *" + query = Query (TE.encodeUtf8 queryText) + PGSimple.queryWith fromRow conn query (dbWhereParams builder) diff --git a/src/Poppy/Internal/Errors.hs b/src/Poppy/Internal/Errors.hs new file mode 100644 --- /dev/null +++ b/src/Poppy/Internal/Errors.hs @@ -0,0 +1,70 @@ +{-# OPTIONS_HADDOCK hide #-} +-- | Errors returned as @Either ORMError@ from Client operations. +module Poppy.Internal.Errors + ( ORMError (..), + DatabaseErrorInfo (..), + DriverErrorKind (..), + requireFound, + fromUniqueRows, + uniqueOrFail, + parseSingleton, + ) +where + +import Control.Exception (Exception) +import Data.Text (Text) + +-- | SQLSTATE, message, and detail from Postgres. +data DatabaseErrorInfo = DatabaseErrorInfo + { sqlState :: Text, + message :: Text, + detail :: Text + } + deriving (Show, Eq) + +-- | @postgresql-simple@ failures that are not constraint violations. +data DriverErrorKind + = FormatMismatch + | ClientQuery + | ResultDecode + deriving (Show, Eq) + +-- | Client and driver failures. Constraint violations are classified; other @SqlError@s are 'DatabaseError'. +data ORMError + = RecordNotFound Text + | MultipleRecordsFound Text + | UniqueViolation Text + | ForeignKeyViolation Text + | NotNullViolation Text + | -- | A write or lookup required a @WHERE@ and none was given. + EmptyWhere Text + | UnsupportedIncludeModifier Text + | -- | Other Postgres @SqlError@ (includes SQLSTATE). + DatabaseError DatabaseErrorInfo + | DriverError DriverErrorKind Text + deriving (Show, Eq) + +instance Exception ORMError + +requireFound :: Maybe a -> ORMError -> Either ORMError a +requireFound Nothing err = Left err +requireFound (Just value) _ = Right value + +fromUniqueRows :: [a] -> Either ORMError (Maybe a) +fromUniqueRows rows = + case rows of + [] -> Right Nothing + [row] -> Right (Just row) + _ -> Left (MultipleRecordsFound "findUnique matched multiple rows") + +uniqueOrFail :: Either ORMError (Maybe a) -> Either ORMError a +uniqueOrFail (Left err) = Left err +uniqueOrFail (Right found) = + requireFound found (RecordNotFound "No record found matching query") + +parseSingleton :: [a] -> ORMError -> ORMError -> Either ORMError a +parseSingleton rows notFoundErr multipleErr = + case rows of + [] -> Left notFoundErr + [row] -> Right row + _ -> Left multipleErr diff --git a/src/Poppy/Internal/Generated.hs b/src/Poppy/Internal/Generated.hs new file mode 100644 --- /dev/null +++ b/src/Poppy/Internal/Generated.hs @@ -0,0 +1,170 @@ +-- | Support for Clients emitted by @poppy-codegen@. +-- +-- Generated @Schema.*@ modules import this module and nothing else from +-- @poppy@. Application code should import 'Poppy' and @Schema.Client.*@ +-- instead. The surface is stable within a major version so a Client built +-- against codegen 1.x keeps working with runtime 1.x. +module Poppy.Internal.Generated + ( -- * Postgres bindings + FromRow (..), + RowParser, + field, + FromField (..), + ResultError (..), + returnError, + ToField (..), + + -- * Table metadata + Entity (..), + Column (..), + SqlType (..), + Field (..), + NullableValue (..), + PrimaryKeyType, + + -- * Connection + Db, + DbPool, + transactionEither, + + -- * Errors + ORMError (..), + DatabaseErrorInfo (..), + DriverErrorKind (..), + requireFound, + fromUniqueRows, + uniqueOrFail, + parseSingleton, + + -- * Select / pick + OmitSelect (..), + Picked (..), + picked, + + -- * Insert + InsertBuilder, + Insertable (..), + insert, + insertMany, + insertBuilder, + insertReturning, + executeInsert, + tryExecuteInsert, + emptyInsert, + onConflictDoNothing, + onConflictDoUpdate, + onConflictDoUpdateSet, + upsert, + set, + setNull, + setMaybe, + setNullable, + setValue, + + -- * Update + UpdateBuilder, + Updatable (..), + update, + updateWhere, + updateBuilder, + updateReturning, + setField, + setFieldNull, + setFieldMaybe, + setFieldNullable, + whereUpdate, + emptyUpdate, + updateMany, + updateSets, + touchUpdatedAt, + + -- * Delete + DeleteBuilder, + deleteWhere, + deleteMany, + deleteReturning, + whereDelete, + emptyDelete, + + -- * Low-level reads + findMany, + findManyWith, + findUnique, + findUniqueOrFail, + findFirst, + findFirstWith, + findFirstOrFail, + count, + delete, + + -- * Query builders + QueryBuilder, + matching, + selectColumns, + applyQueryModifiers, + OrderBy (..), + OrderDirection (..), + asc, + desc, + limit, + offset, + orderBy, + selectAll, + select, + + -- * Where + Where, + eq, + neq, + gt, + gte, + lt, + lte, + in_, + contains, + isNull, + and_, + or_, + not_, + compileWhere, + + -- * Includes + Skip (..), + Load (..), + load, + loadWith, + skip, + skipped, + Skipped, + ModelTable, + IncludeFor, + ValidEdge, + requireRelated, + GroupIndex, + ByPk, + findByIn, + emptyGroups, + indexHasMany, + indexHasManyMaybe, + lookupGroups, + emptyByPk, + indexByPk, + lookupByPk, + prepareIncludeRootQuery, + ) +where + +import Poppy.Internal.Column () +import Poppy.Internal.Core +import Poppy.Internal.Db (Db, DbPool, transactionEither) +import Poppy.Internal.Delete +import Poppy.Internal.Errors +import Poppy.Internal.Include +import Poppy.Internal.Insert +import Poppy.Internal.Operations hiding (ORMError (..)) +import Poppy.Internal.PG +import Poppy.Internal.Query +import Poppy.Internal.Select +import Poppy.Internal.SelectIn +import Poppy.Internal.Update +import Poppy.Internal.Where diff --git a/src/Poppy/Internal/Group.hs b/src/Poppy/Internal/Group.hs new file mode 100644 --- /dev/null +++ b/src/Poppy/Internal/Group.hs @@ -0,0 +1,20 @@ +{-# OPTIONS_HADDOCK hide #-} +module Poppy.Internal.Group + ( groupByKey, + ) +where + +import Data.List (foldl', sortOn) +import qualified Data.Map.Strict as Map + +-- | Group rows by key, preserving first-seen key order and row order within +-- each group. Unlike a 'Map'-ordered group, this matches SELECT order so +-- nested includes stay stable when the join is ordered. +groupByKey :: (Ord k) => (a -> k) -> [a] -> [[a]] +groupByKey keyFn rows = + map snd . sortOn fst . Map.elems $ foldl' add Map.empty rows + where + add acc row = + Map.alter (upsert (Map.size acc) row) (keyFn row) acc + upsert idx row Nothing = Just (idx, [row]) + upsert _ row (Just (idx, xs)) = Just (idx, xs ++ [row]) diff --git a/src/Poppy/Internal/Include.hs b/src/Poppy/Internal/Include.hs new file mode 100644 --- /dev/null +++ b/src/Poppy/Internal/Include.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_HADDOCK hide #-} + +-- | Include edges for generated @Schema.Include.*@ modules. +-- +-- 'skip' omits a relation. 'load' fetches its rows, and 'loadWith' nests +-- another include. Record-update 'where_', 'orderBy_', and 'take_' on +-- 'load' or 'loadWith' to filter that edge. 'take_' is per parent. +-- Import the result constructor +-- (@BookWith (..)@), or a skipped field is reported as a missing @HasField@ +-- instance. +module Poppy.Internal.Include + ( Skip (..), + Load (..), + load, + loadWith, + skip, + skipped, + Skipped, + ModelTable, + IncludeFor, + ValidEdge, + requireRelated, + ) +where + +import Data.Kind (Constraint, Type) +import GHC.TypeLits (ErrorMessage (..), Symbol, TypeError) +import Poppy.Internal.Query (OrderBy) +import Poppy.Internal.Where (Where) + +data Skip = Skip + deriving (Show, Eq) + +-- | One loaded relation. +-- +-- 'include_' is the nested include, or @()@ when this edge stops here. +-- 'where_' and 'orderBy_' use the child table. 'take_' keeps that many +-- child rows for each parent; 'Nothing' keeps every match. Empty +-- 'orderBy_' sorts by the child primary key. +data Load table include = Load + { include_ :: include, + where_ :: Maybe (Where table), + orderBy_ :: [OrderBy table], + take_ :: Maybe Int + } + deriving (Show, Eq) + +-- | Load every related row, with no nested include. +load :: Load table () +load = + Load + { include_ = (), + where_ = Nothing, + orderBy_ = [], + take_ = Nothing + } + +-- | Load related rows and nest @include_@. Filters match 'load'. +loadWith :: include -> Load table include +loadWith include_ = + Load + { include_ = include_, + where_ = Nothing, + orderBy_ = [], + take_ = Nothing + } + +skip :: Skip +skip = Skip + +-- | Placeholder stored in a skipped field. Forcing it is a type error +-- ('Skipped'), so this value is only for constructing the result. +skipped :: a +skipped = error "Poppy: relation was not included" + +type Skipped (name :: Symbol) (loaded :: Type) = + TypeError + ( Text "'" + :<>: Text name + :<>: Text "' was skipped: NotIncluded vs " + :<>: ShowType loaded + ) + +-- | Generated: @type instance ModelTable \"Book\" = BookTable@. +-- Ties an include edge to the child table so 'where_' cannot target +-- a different model. +type family ModelTable (model :: Symbol) :: Type + +class IncludeFor (model :: Symbol) (include :: Type) + +type family ValidEdge (model :: Symbol) (edge :: Type) :: Constraint where + ValidEdge _ Skip = () + ValidEdge model (Load table ()) = table ~ ModelTable model + ValidEdge model (Load table include) = + (table ~ ModelTable model, IncludeFor model include) + ValidEdge model other = + TypeError + ( Text "A " + :<>: Text model + :<>: Text " relation is skip or load, got " + :<>: ShowType other + ) + +-- | A required belongs-to whose parent row is missing. +requireRelated :: String -> Maybe a -> a +requireRelated name Nothing = + error ("Poppy: required relation '" ++ name ++ "' row was missing") +requireRelated _ (Just row) = row diff --git a/src/Poppy/Internal/Insert.hs b/src/Poppy/Internal/Insert.hs new file mode 100644 --- /dev/null +++ b/src/Poppy/Internal/Insert.hs @@ -0,0 +1,252 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_HADDOCK hide #-} + +module Poppy.Internal.Insert + ( InsertBuilder, + Insertable (..), + insert, + insertMany, + insertBuilder, + insertReturning, + executeInsert, + tryExecuteInsert, + emptyInsert, + onConflictDoNothing, + onConflictDoUpdate, + onConflictDoUpdateSet, + upsert, + set, + setNull, + setMaybe, + setNullable, + setValue, + ) +where + +import Control.Monad.IO.Class (liftIO) +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as TE +import Data.Time (getCurrentTime) +import Database.PostgreSQL.Simple (Connection) +import qualified Database.PostgreSQL.Simple as PGSimple +import Database.PostgreSQL.Simple.FromRow (FromRow, fromRow) +import Database.PostgreSQL.Simple.ToField (Action, ToField, toField) +import Database.PostgreSQL.Simple.Types (Query (..)) +import Poppy.Internal.Core (Entity (..), Field (..), NullableValue (..)) +import Poppy.Internal.Db (Db, dbIO, transactionEither) +import Poppy.Internal.Errors (ORMError (..), parseSingleton) +import Poppy.Internal.Sql (catchSql, quoteIdent) +import qualified Poppy.Internal.Update as Update + +class (Entity table) => Insertable table where + type CreateInput table + toInsertBuilder :: CreateInput table -> InsertBuilder table + +data InsertBuilder table = InsertBuilder + { ibTable :: Text, + ibColumns :: [Text], + ibValues :: [Action], + ibConflict :: OnConflict + } + +data OnConflict + = NoConflict + | DoNothing [Text] + | DoUpdate [Text] [Text] + | DoUpdateSet [Text] [(Text, Action)] + +insert :: + forall table result. + (Insertable table, FromRow result) => + CreateInput table -> + Db (Either ORMError result) +insert input = insertBuilder (toInsertBuilder @table input) + +-- | Sequential inserts in one transaction (not a multi-row @INSERT@). Empty list succeeds with @0@. +insertMany :: + forall table. + (Insertable table) => + [CreateInput table] -> + Db (Either ORMError Int) +insertMany [] = pure (Right 0) +insertMany inputs = transactionEither (go 0 inputs) + where + go n [] = pure (Right n) + go n (input : rest) = do + result <- tryExecuteInsert (toInsertBuilder @table input) + case result of + Left err -> pure (Left err) + Right () -> go (n + 1) rest + +-- | @INSERT … ON CONFLICT (conflictCols) DO UPDATE@ using the update payload, not @EXCLUDED@. +upsert :: + forall table result. + (Insertable table, Update.Updatable table, FromRow result) => + [Text] -> + CreateInput table -> + Update.UpdateInput table -> + Db (Either ORMError result) +upsert conflictCols createInput updateInput = do + now <- liftIO getCurrentTime + let insertB = toInsertBuilder @table createInput + updateB = Update.touchUpdatedAt @table now (Update.toUpdateBuilder @table updateInput) + sets = Update.updateSets updateB + builder = + if null sets + then onConflictDoUpdate conflictCols conflictCols insertB + else onConflictDoUpdateSet conflictCols sets insertB + insertBuilder builder + +insertBuilder :: + forall table result. + (FromRow result) => + InsertBuilder table -> + Db (Either ORMError result) +insertBuilder builder = dbIO $ \conn -> do + result <- catchSql (runInsertReturning conn builder) + pure $ + case result of + Left err -> Left err + Right rows -> + parseSingleton + rows + (RecordNotFound $ "INSERT into " <> ibTable builder <> " returned no rows") + (MultipleRecordsFound "Insert returned multiple rows") + +insertReturning :: + forall table result. + (FromRow result) => + InsertBuilder table -> + Db [result] +insertReturning builder = dbIO (`runInsertReturning` builder) + +executeInsert :: InsertBuilder table -> Db () +executeInsert builder = dbIO (`runExecuteInsert` builder) + +tryExecuteInsert :: InsertBuilder table -> Db (Either ORMError ()) +tryExecuteInsert builder = dbIO $ \conn -> catchSql (runExecuteInsert conn builder) + +emptyInsert :: forall table. (Entity table) => InsertBuilder table +emptyInsert = + InsertBuilder + { ibTable = tableName @table, + ibColumns = [], + ibValues = [], + ibConflict = NoConflict + } + +onConflictDoNothing :: [Text] -> InsertBuilder table -> InsertBuilder table +onConflictDoNothing cols builder = builder {ibConflict = DoNothing cols} + +onConflictDoUpdate :: [Text] -> [Text] -> InsertBuilder table -> InsertBuilder table +onConflictDoUpdate cols setCols builder = builder {ibConflict = DoUpdate cols setCols} + +onConflictDoUpdateSet :: [Text] -> [(Text, Action)] -> InsertBuilder table -> InsertBuilder table +onConflictDoUpdateSet cols sets builder = builder {ibConflict = DoUpdateSet cols sets} + +set :: forall table a. (ToField a) => Field table a -> a -> InsertBuilder table -> InsertBuilder table +set field value builder = + builder + { ibColumns = ibColumns builder ++ [fieldColumn field], + ibValues = ibValues builder ++ [toField value] + } + +setValue :: forall table a. (Entity table, ToField a) => Field table a -> a -> InsertBuilder table +setValue field value = set field value (emptyInsert @table) + +setNull :: + forall table a. + (ToField (Maybe a)) => + Field table a -> + InsertBuilder table -> + InsertBuilder table +setNull field builder = + builder + { ibColumns = ibColumns builder ++ [fieldColumn field], + ibValues = ibValues builder ++ [toField (Nothing :: Maybe a)] + } + +setMaybe :: + forall table a. + (ToField a) => + Field table a -> + Maybe a -> + InsertBuilder table -> + InsertBuilder table +setMaybe _ Nothing builder = builder +setMaybe field (Just value) builder = set field value builder + +setNullable :: + forall table a. + (ToField a, ToField (Maybe a)) => + Field table a -> + NullableValue a -> + InsertBuilder table -> + InsertBuilder table +setNullable _ Omit builder = builder +setNullable field (Value value) builder = set field value builder +setNullable field Null builder = setNull field builder + +runInsertReturning :: + forall table result. + (FromRow result) => + Connection -> + InsertBuilder table -> + IO [result] +runInsertReturning conn builder = + let (queryText, allValues) = insertQueryParts builder " RETURNING *" + query = Query (TE.encodeUtf8 queryText) + in PGSimple.queryWith fromRow conn query allValues + +runExecuteInsert :: + Connection -> + InsertBuilder table -> + IO () +runExecuteInsert conn builder = do + let (queryText, allValues) = insertQueryParts builder "" + query = Query (TE.encodeUtf8 queryText) + _ <- PGSimple.execute conn query allValues + pure () + +insertQueryParts :: InsertBuilder table -> Text -> (Text, [Action]) +insertQueryParts builder suffix = + let allColumns = ibColumns builder + allValues = ibValues builder + (conflictSql, conflictParams) = conflictParts (ibConflict builder) + placeholders = Text.intercalate ", " $ replicate (length allValues) "?" + columnsText = Text.intercalate ", " (map quoteIdent allColumns) + queryText = + "INSERT INTO " + <> quoteIdent (ibTable builder) + <> " (" + <> columnsText + <> ") VALUES (" + <> placeholders + <> ")" + <> conflictSql + <> suffix + in (queryText, allValues ++ conflictParams) + +conflictParts :: OnConflict -> (Text, [Action]) +conflictParts NoConflict = ("", []) +conflictParts (DoNothing cols) = + (" ON CONFLICT (" <> Text.intercalate ", " (map quoteIdent cols) <> ") DO NOTHING", []) +conflictParts (DoUpdate cols setCols) = + ( " ON CONFLICT (" + <> Text.intercalate ", " (map quoteIdent cols) + <> ") DO UPDATE SET " + <> Text.intercalate ", " [quoteIdent col <> " = EXCLUDED." <> quoteIdent col | col <- setCols], + [] + ) +conflictParts (DoUpdateSet cols sets) = + ( " ON CONFLICT (" + <> Text.intercalate ", " (map quoteIdent cols) + <> ") DO UPDATE SET " + <> Text.intercalate ", " [quoteIdent col <> " = ?" | (col, _) <- sets], + map snd sets + ) diff --git a/src/Poppy/Internal/Migrate.hs b/src/Poppy/Internal/Migrate.hs new file mode 100644 --- /dev/null +++ b/src/Poppy/Internal/Migrate.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_HADDOCK hide #-} + +-- | Apply hand-written @.sql@ files and record names in @_poppy_migrations@. +module Poppy.Internal.Migrate + ( MigrateError (..), + applyMigrations, + ) +where + +import Control.Exception (IOException, displayException, try) +import Control.Monad (filterM, void) +import qualified Data.ByteString as B8 +import Data.List (isPrefixOf, sort) +import Data.Text (Text) +import qualified Data.Text as T +import Database.PostgreSQL.Simple (Connection, Only (..)) +import qualified Database.PostgreSQL.Simple as PG +import Database.PostgreSQL.Simple.Types (Query (..)) +import Poppy.Internal.Db (DbPool, withConn) +import Poppy.Internal.Errors (ORMError) +import Poppy.Internal.Sql (catchSql) +import System.Directory (doesDirectoryExist, doesFileExist, listDirectory) +import System.FilePath (takeExtension, ()) + +-- | Missing directory / unreadable file, or a SQL file that Postgres rejected. +data MigrateError + = -- | Directory missing or a migration file could not be read. + MigrateDirectoryError Text + | -- | Postgres rejected that file; the name is not recorded. + MigrateFailed Text ORMError + deriving (Show, Eq) + +-- | Run pending @*.sql@ files in @dir@ (sorted, not hidden) against the pool. +-- Creates @_poppy_migrations@ if needed. Returns names applied on this call. +-- A failed file is not recorded; fix it and re-run. Poppy does not generate SQL. +applyMigrations :: DbPool -> FilePath -> IO (Either MigrateError [Text]) +applyMigrations pool dir = do + listed <- listMigrationFiles dir + case listed of + Left err -> pure (Left err) + Right files -> withConn pool $ \conn -> do + ensureHistoryTable conn + applied <- fetchApplied conn + let pending = filter (\(name, _) -> name `notElem` applied) files + applyPending conn pending + +listMigrationFiles :: FilePath -> IO (Either MigrateError [(Text, FilePath)]) +listMigrationFiles dir = do + exists <- doesDirectoryExist dir + if not exists + then pure (Left (MigrateDirectoryError ("not a directory: " <> T.pack dir))) + else do + names <- listDirectory dir + let sqlNames = sort (filter isMigrationName names) + fileNames <- filterM (\name -> doesFileExist (dir name)) sqlNames + pure (Right [(T.pack name, dir name) | name <- fileNames]) + +isMigrationName :: FilePath -> Bool +isMigrationName name = + takeExtension name == ".sql" && not ("." `isPrefixOf` name) + +ensureHistoryTable :: Connection -> IO () +ensureHistoryTable conn = + void (PG.execute_ conn historyTableSql) + +historyTableSql :: Query +historyTableSql = + "CREATE TABLE IF NOT EXISTS _poppy_migrations (\ + \ name TEXT PRIMARY KEY,\ + \ applied_at TIMESTAMPTZ NOT NULL DEFAULT CURRENT_TIMESTAMP\ + \)" + +fetchApplied :: Connection -> IO [Text] +fetchApplied conn = do + rows <- PG.query_ conn "SELECT name FROM _poppy_migrations" + pure [name | Only name <- rows] + +applyPending :: + Connection -> + [(Text, FilePath)] -> + IO (Either MigrateError [Text]) +applyPending conn = go [] + where + go acc [] = pure (Right (reverse acc)) + go acc ((name, path) : rest) = do + result <- applyOne conn name path + case result of + Left err -> pure (Left err) + Right () -> go (name : acc) rest + +applyOne :: Connection -> Text -> FilePath -> IO (Either MigrateError ()) +applyOne conn name path = do + sqlResult <- try @IOException (B8.readFile path) + case sqlResult of + Left ex -> + pure (Left (MigrateDirectoryError (T.pack (displayException ex)))) + Right sql -> do + result <- + catchSql $ + PG.withTransaction conn $ do + _ <- PG.execute_ conn (Query sql) + _ <- PG.execute conn insertHistorySql (Only name) + pure () + case result of + Left err -> pure (Left (MigrateFailed name err)) + Right () -> pure (Right ()) + +insertHistorySql :: Query +insertHistorySql = "INSERT INTO _poppy_migrations (name) VALUES (?)" diff --git a/src/Poppy/Internal/Operations.hs b/src/Poppy/Internal/Operations.hs new file mode 100644 --- /dev/null +++ b/src/Poppy/Internal/Operations.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_HADDOCK hide #-} + +-- | Low-level reads used by generated Clients. Application code calls @Schema.Client.*@. +module Poppy.Internal.Operations + ( findMany, + findManyWith, + findUnique, + findUniqueOrFail, + findFirst, + findFirstWith, + findFirstOrFail, + count, + delete, + ORMError (..), + ) +where + +import qualified Data.Text as Text +import Database.PostgreSQL.Simple.FromRow (FromRow, RowParser) +import Database.PostgreSQL.Simple.ToField (ToField) +import Poppy.Internal.Core (Entity (..), PrimaryKeyType) +import Poppy.Internal.Db (Db (..)) +import qualified Poppy.Internal.Delete as Delete +import Poppy.Internal.Errors (ORMError (..), requireFound) +import Poppy.Internal.Query + ( QueryBuilder, + limit, + matching, + runCountQuery, + runQuery, + runQueryOne, + runQueryWith, + selectAll, + ) +import Poppy.Internal.Where (compileWhere, eq) + +findMany :: + forall table result. + (Entity table, FromRow result) => + (QueryBuilder table -> QueryBuilder table) -> + Db [result] +findMany modifier = runQuery (modifier (selectAll @table)) + +findManyWith :: + forall table result. + (Entity table) => + RowParser result -> + (QueryBuilder table -> QueryBuilder table) -> + Db [result] +findManyWith parser modifier = runQueryWith parser (modifier (selectAll @table)) + +findUnique :: + forall table result. + (Entity table, FromRow result, ToField (PrimaryKeyType table)) => + PrimaryKeyType table -> + Db (Maybe result) +findUnique pkValue = + runQueryOne $ + matching (eq (primaryKey @table) pkValue) (selectAll @table) + +findUniqueOrFail :: + forall table result. + (Entity table, FromRow result, ToField (PrimaryKeyType table), Show (PrimaryKeyType table)) => + PrimaryKeyType table -> + Db (Either ORMError result) +findUniqueOrFail pkValue = do + result <- findUnique @table @result pkValue + pure $ + requireFound result $ + RecordNotFound ("Record not found with primary key: " <> Text.pack (show pkValue)) + +findFirst :: + forall table result. + (Entity table, FromRow result) => + (QueryBuilder table -> QueryBuilder table) -> + Db (Maybe result) +findFirst modifier = runQueryOne (modifier (selectAll @table)) + +findFirstWith :: + forall table result. + (Entity table) => + RowParser result -> + (QueryBuilder table -> QueryBuilder table) -> + Db (Maybe result) +findFirstWith parser modifier = do + results <- runQueryWith parser (limit 1 (modifier (selectAll @table))) + pure $ case results of + [] -> Nothing + (row : _) -> Just row + +findFirstOrFail :: + forall table result. + (Entity table, FromRow result) => + (QueryBuilder table -> QueryBuilder table) -> + Db (Either ORMError result) +findFirstOrFail modifier = do + result <- findFirst @table modifier + pure $ + requireFound result $ + RecordNotFound "No record found matching criteria" + +count :: + forall table. + (Entity table) => + (QueryBuilder table -> QueryBuilder table) -> + Db Int +count modifier = runCountQuery (modifier (selectAll @table)) + +delete :: + forall table. + (Entity table, ToField (PrimaryKeyType table)) => + PrimaryKeyType table -> + Db (Either ORMError Int) +delete pkValue = + let (sql, params) = compileWhere (eq (primaryKey @table) pkValue) + builder = Delete.whereDelete sql params (Delete.emptyDelete @table) + in Delete.deleteWhere builder diff --git a/src/Poppy/Internal/PG.hs b/src/Poppy/Internal/PG.hs new file mode 100644 --- /dev/null +++ b/src/Poppy/Internal/PG.hs @@ -0,0 +1,19 @@ +{-# OPTIONS_HADDOCK hide #-} +module Poppy.Internal.PG + ( FromRow (..), + RowParser, + field, + FromField (..), + ResultError (..), + returnError, + ToField (..), + ) +where + +import Database.PostgreSQL.Simple.FromField + ( FromField (..), + ResultError (..), + returnError, + ) +import Database.PostgreSQL.Simple.FromRow (FromRow (..), RowParser, field) +import Database.PostgreSQL.Simple.ToField (ToField (..)) diff --git a/src/Poppy/Internal/Query.hs b/src/Poppy/Internal/Query.hs new file mode 100644 --- /dev/null +++ b/src/Poppy/Internal/Query.hs @@ -0,0 +1,213 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_HADDOCK hide #-} + +-- | Query builders used by generated Clients (@matching@, @asc@ / @desc@, @limit@). +module Poppy.Internal.Query + ( Query, + QueryBuilder, + queryWhereClauses, + queryLimit, + queryOffset, + queryOrderBy, + select, + selectAll, + selectColumns, + matching, + orderBy, + setOrderBy, + asc, + desc, + limit, + offset, + applyQueryModifiers, + OrderBy (..), + OrderDirection (..), + buildWhereClause, + runQuery, + runQueryWith, + runQueryOne, + runCountQuery, + ) +where + +import Data.Int (Int64) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import Data.Text.Encoding.Error (lenientDecode) +import Database.PostgreSQL.Simple (Only (..)) +import qualified Database.PostgreSQL.Simple as PGSimple +import Database.PostgreSQL.Simple.FromRow (FromRow, RowParser, fromRow) +import Database.PostgreSQL.Simple.ToField (Action) +import Database.PostgreSQL.Simple.Types (Query (..)) +import Poppy.Internal.Core (Entity (..), Field (..)) +import Poppy.Internal.Db (Db, dbIO, logSql) +import Poppy.Internal.Sql (quoteIdent) +import Poppy.Internal.Where (Where, compileWhere) + +data QueryBuilder table = QueryBuilder + { qbTable :: Text, + qbColumns :: [Text], + qbWhere :: [Where table], + qbOrderBy :: [OrderBy table], + qbLimit :: Maybe Int, + qbOffset :: Maybe Int + } + +data OrderDirection = Asc | Desc + deriving (Show, Eq) + +data OrderBy table = OrderBy Text OrderDirection + deriving (Show, Eq) + +-- | @ASC@ +asc :: Field table a -> OrderBy table +asc field = OrderBy (fieldColumn field) Asc + +-- | @DESC@ +desc :: Field table a -> OrderBy table +desc field = OrderBy (fieldColumn field) Desc + +-- | All columns, no filter. +selectAll :: forall table. (Entity table) => QueryBuilder table +selectAll = + QueryBuilder + { qbTable = tableName @table, + qbColumns = tableColumns @table, + qbWhere = [], + qbOrderBy = [], + qbLimit = Nothing, + qbOffset = Nothing + } + +select :: forall table. (Entity table) => QueryBuilder table +select = selectAll @table + +selectColumns :: [Text] -> QueryBuilder table -> QueryBuilder table +selectColumns cols qb = qb {qbColumns = cols} + +-- | Append a @WHERE@ clause (root table). +matching :: Where table -> QueryBuilder table -> QueryBuilder table +matching clause qb = + qb {qbWhere = qbWhere qb ++ [clause]} + +-- | Append an @ORDER BY@ column. +orderBy :: Field table a -> OrderDirection -> QueryBuilder table -> QueryBuilder table +orderBy field dir qb = + qb {qbOrderBy = qbOrderBy qb ++ [OrderBy (fieldColumn field) dir]} + +-- | @LIMIT@ +limit :: Int -> QueryBuilder table -> QueryBuilder table +limit n qb = qb {qbLimit = Just n} + +-- | @OFFSET@ +offset :: Int -> QueryBuilder table -> QueryBuilder table +offset n qb = qb {qbOffset = Just n} + +queryWhereClauses :: QueryBuilder table -> [(Text, [Action])] +queryWhereClauses qb = + case qbWhere qb of + [] -> [] + preds -> + let compiled = map compileWhere preds + sql = T.intercalate " AND " ["(" <> s <> ")" | (s, _) <- compiled] + params = concatMap snd compiled + in [(sql, params)] + +queryLimit :: QueryBuilder table -> Maybe Int +queryLimit = qbLimit + +queryOffset :: QueryBuilder table -> Maybe Int +queryOffset = qbOffset + +queryOrderBy :: QueryBuilder table -> [OrderBy table] +queryOrderBy = qbOrderBy + +applyQueryModifiers :: + Maybe (Where table) -> + [OrderBy table] -> + Maybe Int -> + Maybe Int -> + QueryBuilder table -> + QueryBuilder table +applyQueryModifiers mWhere orders mLimit mOffset = + maybe id matching mWhere + . setOrderBy orders + . maybe id limit mLimit + . maybe id offset mOffset + +-- | Replace the @ORDER BY@ list. +setOrderBy :: [OrderBy table] -> QueryBuilder table -> QueryBuilder table +setOrderBy orders qb = qb {qbOrderBy = orders} + +buildQuery :: QueryBuilder table -> (Query, [Action]) +buildQuery qb = + let baseQuery = "SELECT " <> buildSelectList (qbColumns qb) <> " FROM " <> quoteIdent (qbTable qb) + clauses = queryWhereClauses qb + whereClause = buildWhereClause (map fst clauses) + orderClause = buildOrderClause (qbOrderBy qb) + limitClause = buildLimitClause (qbLimit qb) + offsetClause = buildOffsetClause (qbOffset qb) + finalQuery = baseQuery <> whereClause <> orderClause <> limitClause <> offsetClause + in (Query (TE.encodeUtf8 finalQuery), concatMap snd clauses) + +buildSelectList :: [Text] -> Text +buildSelectList cols = T.intercalate ", " (map quoteIdent cols) + +buildCountQuery :: QueryBuilder table -> (Query, [Action]) +buildCountQuery qb = + let clauses = queryWhereClauses qb + finalQuery = "SELECT COUNT(*) FROM " <> quoteIdent (qbTable qb) <> buildWhereClause (map fst clauses) + in (Query (TE.encodeUtf8 finalQuery), concatMap snd clauses) + +buildWhereClause :: [Text] -> Text +buildWhereClause [] = "" +buildWhereClause conditions = " WHERE " <> T.intercalate " AND " conditions + +buildOrderClause :: [OrderBy table] -> Text +buildOrderClause [] = "" +buildOrderClause terms = + " ORDER BY " <> T.intercalate ", " (map termSql terms) + where + termSql (OrderBy col dir) = + quoteIdent col <> case dir of + Asc -> " ASC" + Desc -> " DESC" + +buildLimitClause :: Maybe Int -> Text +buildLimitClause Nothing = "" +buildLimitClause (Just n) = " LIMIT " <> T.pack (show n) + +buildOffsetClause :: Maybe Int -> Text +buildOffsetClause Nothing = "" +buildOffsetClause (Just n) = " OFFSET " <> T.pack (show n) + +runQuery :: (FromRow result) => QueryBuilder table -> Db [result] +runQuery = runQueryWith fromRow + +runQueryWith :: RowParser result -> QueryBuilder table -> Db [result] +runQueryWith parser qb = do + let (query, params) = buildQuery qb + logSql (queryText query) + dbIO $ \conn -> PGSimple.queryWith parser conn query params + +runQueryOne :: (FromRow result) => QueryBuilder table -> Db (Maybe result) +runQueryOne qb = do + results <- runQuery (limit 1 qb) + pure $ case results of + [] -> Nothing + (x : _) -> Just x + +runCountQuery :: QueryBuilder table -> Db Int +runCountQuery qb = do + let (query, params) = buildCountQuery qb + logSql (queryText query) + dbIO $ \conn -> do + [Only count] <- PGSimple.query conn query params + pure (fromIntegral (count :: Int64)) + +queryText :: Query -> Text +queryText (Query bytes) = TE.decodeUtf8With lenientDecode bytes diff --git a/src/Poppy/Internal/Select.hs b/src/Poppy/Internal/Select.hs new file mode 100644 --- /dev/null +++ b/src/Poppy/Internal/Select.hs @@ -0,0 +1,22 @@ +{-# OPTIONS_HADDOCK hide #-} +-- | Column picking for generated @*Select@ records. Default is 'OmitSelect' (full row). +module Poppy.Internal.Select + ( OmitSelect (..), + Picked (..), + picked, + ) +where + +-- | @select_@ default: every column, result is the full row type. +data OmitSelect = OmitSelect + deriving (Show, Eq) + +-- | One column in a partial select. +data Picked a + = Picked a + | Skipped + deriving (Show, Eq) + +picked :: Bool -> a -> Picked a +picked True value = Picked value +picked False _ = Skipped diff --git a/src/Poppy/Internal/SelectIn.hs b/src/Poppy/Internal/SelectIn.hs new file mode 100644 --- /dev/null +++ b/src/Poppy/Internal/SelectIn.hs @@ -0,0 +1,192 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_HADDOCK hide #-} + +module Poppy.Internal.SelectIn + ( GroupIndex, + ByPk, + findByIn, + emptyGroups, + indexHasMany, + indexHasManyMaybe, + lookupGroups, + emptyByPk, + indexByPk, + lookupByPk, + prepareIncludeRootQuery, + ) +where + +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Database.PostgreSQL.Simple as PGSimple +import Database.PostgreSQL.Simple.FromRow (FromRow, fromRow) +import Database.PostgreSQL.Simple.ToField (Action, ToField, toField) +import Database.PostgreSQL.Simple.Types (In (..), Query (..)) +import Poppy.Internal.Core (Entity (..), Field (..)) +import Poppy.Internal.Db (Db, dbIO, logSql) +import Poppy.Internal.Group (groupByKey) +import qualified Poppy.Internal.Operations as Ops +import Poppy.Internal.Query + ( OrderBy (..), + OrderDirection (..), + QueryBuilder, + matching, + orderBy, + queryOrderBy, + setOrderBy, + ) +import Poppy.Internal.Sql (quoteIdent) +import Poppy.Internal.Where (Where, compileWhere, in_) + +newtype GroupIndex k a = GroupIndex (Map k [a]) + +newtype ByPk k a = ByPk (Map k a) + +findByIn :: + forall table result key. + (Entity table, FromRow result, ToField key) => + Field table key -> + [key] -> + Maybe (Where table) -> + [OrderBy table] -> + Maybe Int -> + Db [result] +findByIn field keys mWhere orders mTake + | null keys = pure [] + | Just n <- mTake, n <= 0 = pure [] + | Just n <- mTake = findTaken @table @result field keys mWhere orders n + | otherwise = + Ops.findMany @table @result $ + setOrderBy (childOrder @table orders) + . maybe id matching mWhere + . matching (in_ field keys) + +findTaken :: + forall table result key. + (Entity table, FromRow result, ToField key) => + Field table key -> + [key] -> + Maybe (Where table) -> + [OrderBy table] -> + Int -> + Db [result] +findTaken field keys mWhere orders n = do + let (sql, params) = takenSql @table field keys mWhere orders n + logSql sql + dbIO $ \conn -> PGSimple.queryWith fromRow conn (Query (TE.encodeUtf8 sql)) params + +takenSql :: + forall table key. + (Entity table, ToField key) => + Field table key -> + [key] -> + Maybe (Where table) -> + [OrderBy table] -> + Int -> + (Text, [Action]) +takenSql field keys mWhere orders n = + let cols = T.intercalate ", " (map quoteIdent (tableColumns @table)) + part = quoteIdent (fieldColumn field) + rn = quoteIdent "poppy_rn" + (extraSql, extraParams) = case mWhere of + Nothing -> ("", []) + Just pred_ -> + let (clause, clauseParams) = compileWhere pred_ + in (" AND (" <> clause <> ")", clauseParams) + sql = + "SELECT " + <> cols + <> " FROM (SELECT " + <> cols + <> ", ROW_NUMBER() OVER (PARTITION BY " + <> part + <> " ORDER BY " + <> orderSql (childOrder @table orders) + <> ") AS " + <> rn + <> " FROM " + <> quoteIdent (tableName @table) + <> " WHERE " + <> part + <> " IN ?" + <> extraSql + <> ") AS " + <> quoteIdent "poppy_window" + <> " WHERE " + <> rn + <> " <= ? ORDER BY " + <> part + <> " ASC, " + <> rn + <> " ASC" + in (sql, toField (In keys) : extraParams ++ [toField n]) + +childOrder :: forall table. (Entity table) => [OrderBy table] -> [OrderBy table] +childOrder orders + | null orders = [OrderBy pk Asc] + | any isPk orders = orders + | otherwise = orders ++ [OrderBy pk Asc] + where + pk = fieldColumn (primaryKey @table) + isPk (OrderBy col _) = col == pk + +orderSql :: [OrderBy table] -> Text +orderSql orders = T.intercalate ", " (map term orders) + where + term (OrderBy col dir) = + quoteIdent col <> case dir of + Asc -> " ASC" + Desc -> " DESC" + +emptyGroups :: GroupIndex k a +emptyGroups = GroupIndex Map.empty + +indexHasMany :: (Ord k) => (a -> k) -> [a] -> GroupIndex k a +indexHasMany keyFn rows = + GroupIndex . Map.fromList $ + [(keyFn (head group), group) | group <- groupByKey keyFn rows] + +-- | Like 'indexHasMany', dropping rows whose key is 'Nothing'. +indexHasManyMaybe :: (Ord k) => (a -> Maybe k) -> [a] -> GroupIndex k a +indexHasManyMaybe keyFn rows = + GroupIndex $ + Map.fromListWith (flip (<>)) [(key, [row]) | row <- rows, Just key <- [keyFn row]] + +lookupGroups :: (Ord k) => k -> GroupIndex k a -> [a] +lookupGroups key (GroupIndex groups) = + Map.findWithDefault [] key groups + +emptyByPk :: ByPk k a +emptyByPk = ByPk Map.empty + +indexByPk :: (Ord k) => (a -> k) -> [a] -> ByPk k a +indexByPk keyFn rows = + ByPk (Map.fromList [(keyFn row, row) | row <- rows]) + +lookupByPk :: (Ord k) => k -> ByPk k a -> Maybe a +lookupByPk key (ByPk byPk) = + Map.lookup key byPk + +prepareIncludeRootQuery :: + forall table. + (Entity table) => + (QueryBuilder table -> QueryBuilder table) -> + QueryBuilder table -> + QueryBuilder table +prepareIncludeRootQuery modifier = + defaultPkOrder @table . modifier + +defaultPkOrder :: + forall table. + (Entity table) => + QueryBuilder table -> + QueryBuilder table +defaultPkOrder qb = + case queryOrderBy qb of + [] -> orderBy (primaryKey @table) Asc qb + _ -> qb diff --git a/src/Poppy/Internal/Sql.hs b/src/Poppy/Internal/Sql.hs new file mode 100644 --- /dev/null +++ b/src/Poppy/Internal/Sql.hs @@ -0,0 +1,104 @@ +{-# OPTIONS_HADDOCK hide #-} +-- | Raw SQL in 'Poppy.Internal.Db.Db': @queryRaw@ / @executeRaw@ with bound 'param's. +module Poppy.Internal.Sql + ( Param (..), + param, + queryRaw, + executeRaw, + catchDb, + catchSql, + fromSqlError, + quoteIdent, + quoteQualified, + ) +where + +import Control.Exception (Handler (..), catches) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding (decodeUtf8With) +import Data.Text.Encoding.Error (lenientDecode) +import Database.PostgreSQL.Simple + ( FormatError (..), + QueryError (..), + SqlError (..), + ) +import qualified Database.PostgreSQL.Simple as PGSimple +import Database.PostgreSQL.Simple.FromField (ResultError (..)) +import Database.PostgreSQL.Simple.FromRow (FromRow, fromRow) +import Database.PostgreSQL.Simple.ToField (Action, ToField, toField) +import Database.PostgreSQL.Simple.Types (Query (..)) +import Poppy.Internal.Db (Db (..), dbIO, logSql) +import Poppy.Internal.Errors (DatabaseErrorInfo (..), DriverErrorKind (..), ORMError (..)) + +newtype Param = Param {unParam :: Action} + +-- | Bind a @ToField@ value as a @?@ placeholder. +param :: (ToField a) => a -> Param +param = Param . toField + +quoteIdent :: Text -> Text +quoteIdent name = "\"" <> T.replace "\"" "\"\"" name <> "\"" + +quoteQualified :: Text -> Text -> Text +quoteQualified alias col = quoteIdent alias <> "." <> quoteIdent col + +-- | @SELECT@ (or anything with a 'FromRow' result). Does not catch driver errors; wrap with 'catchDb'. +queryRaw :: (FromRow r) => Query -> [Param] -> Db [r] +queryRaw query params = do + logSql (sqlText query) + dbIO $ \conn -> + PGSimple.queryWith fromRow conn query (map unParam params) + +-- | Statement with no result rows. Returns affected row count. Does not catch driver errors. +executeRaw :: Query -> [Param] -> Db Int +executeRaw query params = do + logSql (sqlText query) + dbIO $ \conn -> + fromIntegral <$> PGSimple.execute conn query (map unParam params) + +sqlText :: Query -> Text +sqlText (Query bytes) = decodeUtf8With lenientDecode bytes + +-- | Turn a driver exception into 'Left' 'ORMError'. +catchDb :: Db a -> Db (Either ORMError a) +catchDb (Db action) = Db $ \env -> catchSql (action env) + +catchSql :: IO a -> IO (Either ORMError a) +catchSql action = + (Right <$> action) + `catches` [ Handler (pure . Left . fromSqlError), + Handler (pure . Left . fromFormatError), + Handler (pure . Left . fromQueryError), + Handler (pure . Left . fromResultError) + ] + +fromSqlError :: SqlError -> ORMError +fromSqlError SqlError {sqlState = state, sqlErrorMsg = msg, sqlErrorDetail = detail} + | state == "23505" = UniqueViolation (decode msg) + | state == "23503" = ForeignKeyViolation (decode msg) + | state == "23502" = NotNullViolation (decode msg) + | otherwise = + databaseError (decode state) (decode msg) (decode detail) + where + decode = decodeUtf8With lenientDecode + +fromFormatError :: FormatError -> ORMError +fromFormatError FormatError {fmtMessage} = + DriverError FormatMismatch (T.pack fmtMessage) + +fromQueryError :: QueryError -> ORMError +fromQueryError QueryError {qeMessage} = + DriverError ClientQuery (T.pack qeMessage) + +fromResultError :: ResultError -> ORMError +fromResultError err = + DriverError ResultDecode (T.pack (resultMessage err)) + where + resultMessage Incompatible {errMessage} = errMessage + resultMessage UnexpectedNull {errMessage} = errMessage + resultMessage ConversionFailed {errMessage} = errMessage + +databaseError :: Text -> Text -> Text -> ORMError +databaseError sqlState message detail = + DatabaseError DatabaseErrorInfo {sqlState, message, detail} diff --git a/src/Poppy/Internal/Update.hs b/src/Poppy/Internal/Update.hs new file mode 100644 --- /dev/null +++ b/src/Poppy/Internal/Update.hs @@ -0,0 +1,258 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-redundant-constraints #-} +{-# OPTIONS_HADDOCK hide #-} + +module Poppy.Internal.Update + ( UpdateBuilder, + Updatable (..), + update, + updateWhere, + updateBuilder, + updateReturning, + setField, + setFieldNull, + setFieldMaybe, + setFieldNullable, + whereUpdate, + emptyUpdate, + updateMany, + updateSets, + touchUpdatedAt, + ) +where + +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as TE +import Data.Time (UTCTime, getCurrentTime) +import Database.PostgreSQL.Simple (Connection) +import qualified Database.PostgreSQL.Simple as PGSimple +import Database.PostgreSQL.Simple.FromRow (FromRow, fromRow) +import Database.PostgreSQL.Simple.ToField (Action, ToField, toField) +import Database.PostgreSQL.Simple.Types (Query (..)) +import Poppy.Internal.Core (Entity (..), Field (..), NullableValue (..), PrimaryKeyType) +import Poppy.Internal.Db (Db (..), dbIO) +import Poppy.Internal.Errors (ORMError (..), parseSingleton) +import qualified Poppy.Internal.Operations as Ops +import Poppy.Internal.Query (buildWhereClause, matching) +import Poppy.Internal.Sql (catchSql, quoteIdent) +import Poppy.Internal.Where (Where, compileWhere) + +class (Entity table) => Updatable table where + type UpdateInput table + toUpdateBuilder :: UpdateInput table -> UpdateBuilder table + updatedAtField :: Maybe (Field table UTCTime) + default updatedAtField :: Maybe (Field table UTCTime) + updatedAtField = Nothing + +data UpdateBuilder table = UpdateBuilder + { ubTable :: Text, + ubSets :: [(Text, Action)], + ubWhere :: [Text], + ubWhereParams :: [Action] + } + +emptyUpdate :: forall table. (Entity table) => UpdateBuilder table +emptyUpdate = + UpdateBuilder + { ubTable = tableName @table, + ubSets = [], + ubWhere = [], + ubWhereParams = [] + } + +setField :: forall table a. (ToField a) => Field table a -> a -> UpdateBuilder table -> UpdateBuilder table +setField field value builder = + builder + { ubSets = ubSets builder ++ [(fieldColumn field, toField value)] + } + +setFieldNull :: + forall table a. + (ToField (Maybe a)) => + Field table a -> + UpdateBuilder table -> + UpdateBuilder table +setFieldNull field builder = + builder + { ubSets = ubSets builder ++ [(fieldColumn field, toField (Nothing :: Maybe a))] + } + +setFieldMaybe :: + forall table a. + (ToField a) => + Field table a -> + Maybe a -> + UpdateBuilder table -> + UpdateBuilder table +setFieldMaybe _ Nothing builder = builder +setFieldMaybe field (Just value) builder = setField field value builder + +setFieldNullable :: + forall table a. + (ToField a, ToField (Maybe a)) => + Field table a -> + NullableValue a -> + UpdateBuilder table -> + UpdateBuilder table +setFieldNullable _ Omit builder = builder +setFieldNullable field (Value value) builder = setField field value builder +setFieldNullable field Null builder = setFieldNull field builder + +whereUpdate :: Text -> [Action] -> UpdateBuilder table -> UpdateBuilder table +whereUpdate condition params builder = + builder + { ubWhere = ubWhere builder ++ [condition], + ubWhereParams = ubWhereParams builder ++ params + } + +update :: + forall table result. + (Updatable table, FromRow result, ToField (PrimaryKeyType table), Show (PrimaryKeyType table)) => + PrimaryKeyType table -> + UpdateInput table -> + Db (Either ORMError result) +update pkValue input = do + let builder = toUpdateBuilder @table input + if null (ubSets builder) + then Ops.findUniqueOrFail @table @result pkValue + else do + now <- liftCurrentTime + let pkField = primaryKey @table + builderWithTouch = touchUpdatedAt @table now builder + builderWithWhere = + whereUpdate + (quoteIdent (fieldColumn pkField) <> " = ?") + [toField pkValue] + builderWithTouch + updateBuilder builderWithWhere + +updateWhere :: + forall table result. + (Updatable table, FromRow result) => + Where table -> + UpdateInput table -> + Db (Either ORMError result) +updateWhere clause input = do + let builder = toUpdateBuilder @table input + if null (ubSets builder) + then do + rows <- Ops.findMany @table @result (matching clause) + pure $ + parseSingleton + rows + (RecordNotFound "No record found to update") + (MultipleRecordsFound "Update matched multiple rows") + else do + now <- liftCurrentTime + let (sql, params) = compileWhere clause + builderWithWhere = + whereUpdate sql params (touchUpdatedAt @table now builder) + updateBuilder builderWithWhere + +updateBuilder :: + forall table result. + (Entity table, FromRow result) => + UpdateBuilder table -> + Db (Either ORMError result) +updateBuilder builder + | null (ubWhere builder) = + pure (Left (EmptyWhere "UPDATE requires a WHERE clause")) + | otherwise = dbIO $ \conn -> do + result <- catchSql (runUpdateReturning conn builder) + pure $ + case result of + Left err -> Left err + Right rows -> + parseSingleton + rows + (RecordNotFound "No record found to update") + (MultipleRecordsFound "Update affected multiple rows") + +updateReturning :: + forall table result. + (Entity table, FromRow result) => + UpdateBuilder table -> + Db (Either ORMError [result]) +updateReturning builder + | null (ubWhere builder) = + pure (Left (EmptyWhere "UPDATE requires a WHERE clause")) + | otherwise = dbIO $ \conn -> catchSql (runUpdateReturning conn builder) + +updateMany :: + forall table. + (Updatable table) => + Where table -> + UpdateInput table -> + Db (Either ORMError Int) +updateMany clause input = do + now <- liftCurrentTime + let (sql, params) = compileWhere clause + builder = + whereUpdate sql params $ + touchUpdatedAt @table now (toUpdateBuilder @table input) + if null (ubSets builder) + then pure (Right 0) + else dbIO $ \conn -> catchSql (runUpdate conn builder) + +updateSets :: UpdateBuilder table -> [(Text, Action)] +updateSets = ubSets + +liftCurrentTime :: Db UTCTime +liftCurrentTime = Db (const getCurrentTime) + +buildSetClause :: [(Text, Action)] -> Text +buildSetClause sets = " SET " <> Text.intercalate ", " (map (\(col, _) -> quoteIdent col <> " = ?") sets) + +runUpdateReturning :: + forall table result. + (FromRow result) => + Connection -> + UpdateBuilder table -> + IO [result] +runUpdateReturning conn builder = do + let setClause = buildSetClause (ubSets builder) + setParams = map snd (ubSets builder) + whereClause = buildWhereClause (ubWhere builder) + allParams = setParams ++ ubWhereParams builder + queryText = + "UPDATE " + <> quoteIdent (ubTable builder) + <> setClause + <> whereClause + <> " RETURNING *" + query = Query (TE.encodeUtf8 queryText) + PGSimple.queryWith fromRow conn query allParams + +runUpdate :: Connection -> UpdateBuilder table -> IO Int +runUpdate conn builder = do + let setClause = buildSetClause (ubSets builder) + setParams = map snd (ubSets builder) + whereClause = buildWhereClause (ubWhere builder) + allParams = setParams ++ ubWhereParams builder + queryText = + "UPDATE " + <> quoteIdent (ubTable builder) + <> setClause + <> whereClause + query = Query (TE.encodeUtf8 queryText) + fromIntegral <$> PGSimple.execute conn query allParams + +touchUpdatedAt :: + forall table. + (Updatable table) => + UTCTime -> + UpdateBuilder table -> + UpdateBuilder table +touchUpdatedAt now builder = + case updatedAtField @table of + Nothing -> builder + Just field -> + if fieldColumn field `elem` map fst (ubSets builder) + then builder + else setField field now builder diff --git a/src/Poppy/Internal/Where.hs b/src/Poppy/Internal/Where.hs new file mode 100644 --- /dev/null +++ b/src/Poppy/Internal/Where.hs @@ -0,0 +1,147 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_HADDOCK hide #-} + +-- | Predicates for query records and include edges. +-- +-- On a generated query record, @where_@ filters the root model. On 'load' +-- or 'loadWith', @where_@ filters that included relation. +module Poppy.Internal.Where + ( Where, + eq, + neq, + gt, + gte, + lt, + lte, + in_, + contains, + isNull, + and_, + or_, + not_, + compileWhere, + equalityColumns, + ) +where + +import Data.Text (Text, unpack) +import Database.PostgreSQL.Simple.ToField (Action, ToField, toField) +import Database.PostgreSQL.Simple.Types (In (..)) +import Poppy.Internal.Core (Field (..)) +import Poppy.Internal.Sql (quoteIdent) + +-- | Predicate on one table: the root of a query record, or the child of an include edge. +data Where table + = WhereCmp Text Text Action + | WhereIn Text Action + | WhereNull Text + | WhereContains Text Action + | WhereAnd (Where table) (Where table) + | WhereOr (Where table) (Where table) + | WhereNot (Where table) + | WhereFalse + +instance Eq (Where table) where + WhereCmp c1 op1 v1 == WhereCmp c2 op2 v2 = + c1 == c2 && op1 == op2 && sameAction v1 v2 + WhereIn c1 v1 == WhereIn c2 v2 = c1 == c2 && sameAction v1 v2 + WhereNull c1 == WhereNull c2 = c1 == c2 + WhereContains c1 v1 == WhereContains c2 v2 = c1 == c2 && sameAction v1 v2 + WhereAnd a1 b1 == WhereAnd a2 b2 = a1 == a2 && b1 == b2 + WhereOr a1 b1 == WhereOr a2 b2 = a1 == a2 && b1 == b2 + WhereNot a == WhereNot b = a == b + WhereFalse == WhereFalse = True + _ == _ = False + +instance Show (Where table) where + show where_ = unpack (fst (compileWhere where_)) + +sameAction :: Action -> Action -> Bool +sameAction a b = show a == show b + +infixr 3 `and_` + +infixr 2 `or_` + +-- | @=@ +eq :: (ToField a) => Field table a -> a -> Where table +eq = cmp "=" + +-- | @<>@ +neq :: (ToField a) => Field table a -> a -> Where table +neq = cmp "<>" + +-- | @>@ +gt :: (ToField a) => Field table a -> a -> Where table +gt = cmp ">" + +-- | @>=@ +gte :: (ToField a) => Field table a -> a -> Where table +gte = cmp ">=" + +-- | @<@ +lt :: (ToField a) => Field table a -> a -> Where table +lt = cmp "<" + +-- | @<=@ +lte :: (ToField a) => Field table a -> a -> Where table +lte = cmp "<=" + +-- | @IN (…)@. Empty list is false. +in_ :: (ToField a) => Field table a -> [a] -> Where table +in_ _ [] = WhereFalse +in_ field values = WhereIn (fieldColumn field) (toField (In values)) + +-- | Case-insensitive substring match (@POSITION@ of the needle in the column). +contains :: Field table Text -> Text -> Where table +contains field value = + WhereContains (fieldColumn field) (toField value) + +-- | @IS NULL@ +isNull :: Field table a -> Where table +isNull field = WhereNull (fieldColumn field) + +-- | @AND@ +and_ :: Where table -> Where table -> Where table +and_ = WhereAnd + +-- | @OR@ +or_ :: Where table -> Where table -> Where table +or_ = WhereOr + +-- | @NOT@ +not_ :: Where table -> Where table +not_ = WhereNot + +cmp :: (ToField a) => Text -> Field table a -> a -> Where table +cmp op field value = + WhereCmp (fieldColumn field) op (toField value) + +-- | Column names of a conjunction of equalities. 'Nothing' if the predicate +-- uses anything other than 'eq' combined with 'and_'. +equalityColumns :: Where table -> Maybe [Text] +equalityColumns = \case + WhereCmp col "=" _ -> Just [col] + WhereAnd left right -> (++) <$> equalityColumns left <*> equalityColumns right + _ -> Nothing + +compileWhere :: Where table -> (Text, [Action]) +compileWhere = \case + WhereCmp col op val -> (quoteIdent col <> " " <> op <> " ?", [val]) + WhereIn col val -> (quoteIdent col <> " IN ?", [val]) + WhereNull col -> (quoteIdent col <> " IS NULL", []) + WhereContains col val -> + ("POSITION(LOWER(?) IN LOWER(" <> quoteIdent col <> ")) > 0", [val]) + WhereAnd left right -> compileBin "AND" left right + WhereOr left right -> compileBin "OR" left right + WhereNot inner -> + let (sql, params) = compileWhere inner + in ("NOT (" <> sql <> ")", params) + WhereFalse -> ("FALSE", []) + +compileBin :: Text -> Where table -> Where table -> (Text, [Action]) +compileBin op left right = + let (leftSql, leftParams) = compileWhere left + (rightSql, rightParams) = compileWhere right + in ("(" <> leftSql <> ") " <> op <> " (" <> rightSql <> ")", leftParams ++ rightParams) diff --git a/test/Poppy/AuthorFixtures.hs b/test/Poppy/AuthorFixtures.hs new file mode 100644 --- /dev/null +++ b/test/Poppy/AuthorFixtures.hs @@ -0,0 +1,25 @@ +module Poppy.AuthorFixtures + ( insertAuthor, + insertPost, + ) +where + +import Data.Text (Text) +import Data.UUID (UUID) +import Poppy (runDb) +import Poppy.Internal.Db (DbPool) +import qualified Poppy.Internal.Insert as Insert +import Schema.Author (AuthorCreate (..), AuthorRow (..), AuthorTable) +import Schema.Post (PostCreate (..), PostRow (..), PostTable) +import Schema.PostStatus (PostStatus) +import Support.Assert (assertRight) + +insertAuthor :: DbPool -> Text -> IO AuthorRow +insertAuthor pool name = + runDb pool (Insert.insert @AuthorTable @AuthorRow (AuthorCreate {id = Nothing, name})) + >>= assertRight + +insertPost :: DbPool -> UUID -> Text -> PostStatus -> IO PostRow +insertPost pool authorId title status = + runDb pool (Insert.insert @PostTable @PostRow (PostCreate {id = Nothing, authorId, title, status})) + >>= assertRight diff --git a/test/Poppy/BelongsToSpec.hs b/test/Poppy/BelongsToSpec.hs new file mode 100644 --- /dev/null +++ b/test/Poppy/BelongsToSpec.hs @@ -0,0 +1,42 @@ +module Poppy.BelongsToSpec + ( belongsToSpec, + ) +where + +import Poppy (load, runDb, skip) +import qualified Poppy.AuthorFixtures as AuthorFixtures +import Schema.Author (AuthorRow (..)) +import qualified Schema.Client.Post as Post +import Schema.Include.Post (PostInclude (..), PostWith (..)) +import Schema.Post (PostRow (..)) +import Schema.PostStatus (PostStatus (..)) +import Support.TestDb (TestEnv (..)) +import Test.Hspec (SpecWith, describe, it, shouldBe) + +belongsToSpec :: SpecWith TestEnv +belongsToSpec = + describe "belongsTo includes" $ do + it "nests the parent row on each child" $ \TestEnv {envPool = pool} -> do + ada <- AuthorFixtures.insertAuthor pool "Ada" + grace <- AuthorFixtures.insertAuthor pool "Grace" + notes <- AuthorFixtures.insertPost pool ada.id "Notes" Draft + compiler <- AuthorFixtures.insertPost pool grace.id "Compiler" Published + results <- + runDb + pool + (Post.findMany (Post.emptyQuery {Post.include_ = PostInclude {author = load}})) + let adaPost = head [r | r <- results, r.post.id == notes.id] + gracePost = head [r | r <- results, r.post.id == compiler.id] + adaPost.author.name `shouldBe` "Ada" + adaPost.author.id `shouldBe` ada.id + gracePost.author.name `shouldBe` "Grace" + gracePost.author.id `shouldBe` grace.id + + it "leaves a skipped parent unread" $ \TestEnv {envPool = pool} -> do + ada <- AuthorFixtures.insertAuthor pool "Ada" + _ <- AuthorFixtures.insertPost pool ada.id "Notes" Draft + results <- + runDb + pool + (Post.findMany (Post.emptyQuery {Post.include_ = PostInclude {author = skip}})) + map ((.title) . (.post)) results `shouldBe` ["Notes"] diff --git a/test/Poppy/ClientWriteSpec.hs b/test/Poppy/ClientWriteSpec.hs new file mode 100644 --- /dev/null +++ b/test/Poppy/ClientWriteSpec.hs @@ -0,0 +1,125 @@ +module Poppy.ClientWriteSpec + ( clientWriteSpec, + ) +where + +import Data.Text (Text) +import Data.UUID.V4 (nextRandom) +import Poppy (NullableValue (Omit, Value), ORMError (..), eq, runDb) +import qualified Schema.Client.Widget as Widget +import Schema.Widget (WidgetCreate (..), WidgetRow (..), WidgetUpdate (..), widgetName) +import Support.Assert (assertRight) +import Support.TestDb (TestEnv (..)) +import Test.Hspec (SpecWith, describe, it, shouldBe, shouldMatchList, shouldSatisfy) + +clientWriteSpec :: SpecWith TestEnv +clientWriteSpec = + describe "generated Client batch writes" $ do + it "createMany inserts rows and counts them" $ \TestEnv {envPool = pool} -> do + n <- + runDb pool (Widget.createMany [widgetCreate "batch-a", widgetCreate "batch-b"]) + >>= assertRight + n `shouldBe` 2 + rows <- runDb pool (Widget.findMany Widget.emptyQuery) + map (.name) rows `shouldMatchList` ["batch-a", "batch-b"] + + it "createMany rolls back when one insert fails" $ \TestEnv {envPool = pool} -> do + uid <- nextRandom + result <- + runDb + pool + ( Widget.createMany + [ (widgetCreate "keep-me") {id = Just uid}, + (widgetCreate "also-same-id") {id = Just uid} + ] + ) + result + `shouldSatisfy` ( \case + Left (UniqueViolation _) -> True + _ -> False + ) + rows <- runDb pool (Widget.findMany Widget.emptyQuery) + rows `shouldBe` [] + + it "updateMany updates matching rows" $ \TestEnv {envPool = pool} -> do + _ <- runDb pool (Widget.create (widgetCreate "before")) >>= assertRight + _ <- runDb pool (Widget.create (widgetCreate "other")) >>= assertRight + n <- + runDb + pool + ( Widget.updateMany + (eq widgetName "before") + widgetUpdate {name = Just "after"} + ) + >>= assertRight + n `shouldBe` 1 + rows <- runDb pool (Widget.findMany Widget.emptyQuery) + map (.name) rows `shouldMatchList` ["after", "other"] + + it "deleteMany deletes matching rows" $ \TestEnv {envPool = pool} -> do + _ <- runDb pool (Widget.create (widgetCreate "keep")) >>= assertRight + _ <- runDb pool (Widget.create (widgetCreate "drop")) >>= assertRight + n <- runDb pool (Widget.deleteMany (eq widgetName "drop")) >>= assertRight + n `shouldBe` 1 + rows <- runDb pool (Widget.findMany Widget.emptyQuery) + map (.name) rows `shouldBe` ["keep"] + + it "upsert OnName updates on conflict" $ \TestEnv {envPool = pool} -> do + inserted <- + runDb + pool + (Widget.upsert Widget.OnName (widgetCreate "first") widgetUpdate) + >>= assertRight + inserted.name `shouldBe` "first" + updated <- + runDb + pool + ( Widget.upsert + Widget.OnName + (widgetCreate "first") + widgetUpdate {name = Just "second"} + ) + >>= assertRight + updated.id `shouldBe` inserted.id + updated.name `shouldBe` "second" + rows <- runDb pool (Widget.findMany Widget.emptyQuery) + map (.name) rows `shouldBe` ["second"] + + it "update and delete take a unique key" $ \TestEnv {envPool = pool} -> do + created <- runDb pool (Widget.create (widgetCreate "sage")) >>= assertRight + same <- + runDb pool (Widget.update (Widget.ByName "sage") widgetUpdate) + >>= assertRight + same.id `shouldBe` created.id + updated <- + runDb + pool + ( Widget.update + (Widget.ByName "sage") + widgetUpdate {description = Value "fresh"} + ) + >>= assertRight + updated.description `shouldBe` Just "fresh" + n <- + runDb pool (Widget.delete (Widget.ById created.id)) + >>= assertRight + n `shouldBe` 1 + +widgetCreate :: Text -> WidgetCreate +widgetCreate name = + WidgetCreate + { id = Nothing, + createdAt = Nothing, + updatedAt = Nothing, + name, + description = Omit + } + +widgetUpdate :: WidgetUpdate +widgetUpdate = + WidgetUpdate + { createdAt = Nothing, + updatedAt = Nothing, + name = Nothing, + description = Omit + } diff --git a/test/Poppy/CommentSpec.hs b/test/Poppy/CommentSpec.hs new file mode 100644 --- /dev/null +++ b/test/Poppy/CommentSpec.hs @@ -0,0 +1,45 @@ +module Poppy.CommentSpec + ( commentSpec, + ) +where + +import Poppy (NullableValue (..), load, loadWith, runDb) +import qualified Poppy.Internal.Insert as Insert +import Poppy.Internal.Where (isNull) +import qualified Schema.Client.Comment as Comment +import Schema.Comment (CommentCreate (..), CommentRow (..), CommentTable, commentParentId) +import Schema.Include.Comment (CommentInclude (..), CommentWith (..)) +import Support.Assert (assertRight) +import Support.TestDb (TestEnv (..)) +import Test.Hspec (SpecWith, describe, it, shouldBe) + +commentSpec :: SpecWith TestEnv +commentSpec = + describe "self-relation includes" $ + it "loads replies two levels deep" $ \TestEnv {envPool = pool} -> do + root <- insert pool "root" Null + child <- insert pool "child" (Value root.id) + _ <- insert pool "grandchild" (Value child.id) + [loaded] <- + runDb + pool + ( Comment.findMany + Comment.emptyQuery + { Comment.include_ = + CommentInclude {replies = loadWith (CommentInclude {replies = load})}, + Comment.where_ = Just (isNull commentParentId) + } + ) + [reply] <- pure loaded.replies + reply.comment.body `shouldBe` "child" + map (.body) reply.replies `shouldBe` ["grandchild"] + where + insert pool body parentId = + runDb + pool + ( Insert.insert + @CommentTable + @CommentRow + (CommentCreate {id = Nothing, parentId, body}) + ) + >>= assertRight diff --git a/test/Poppy/DbSpec.hs b/test/Poppy/DbSpec.hs new file mode 100644 --- /dev/null +++ b/test/Poppy/DbSpec.hs @@ -0,0 +1,71 @@ +module Poppy.DbSpec + ( dbSpec, + ) +where + +import Control.Exception (bracket) +import Data.IORef (modifyIORef', newIORef, readIORef) +import Data.Int (Int64) +import Data.Text (Text) +import qualified Data.Text as T +import Database.PostgreSQL.Simple.FromRow (FromRow (..), field) +import Database.PostgreSQL.Simple.Types (Query (..)) +import Poppy (DbPool, PoolConfig (..), closePool, connectWith, defaultPool, runDb) +import qualified Poppy.Internal.Operations as Ops +import Poppy.Internal.Query (matching) +import Poppy.Internal.Sql (executeRaw, param, queryRaw) +import Poppy.Internal.Where (eq) +import Schema.Widget (WidgetTable, widgetName) +import Support.TestDb (TestEnv, testDatabaseUrl) +import Test.Hspec (SpecWith, describe, it, shouldBe, shouldSatisfy) + +data CountRow = CountRow {cnt :: Int64} + deriving (Eq, Show) + +instance FromRow CountRow where + fromRow = CountRow <$> field + +withCustomPool :: PoolConfig -> (DbPool -> IO a) -> IO a +withCustomPool config action = do + url <- testDatabaseUrl + bracket (connectWith config url) closePool action + +dbSpec :: SpecWith TestEnv +dbSpec = + describe "Poppy.Internal.Db pool config" $ do + it "connectWith a one-connection pool still runs a query" $ \_ -> + withCustomPool defaultPool {poolStripes = 1, poolMaxPerStripe = 1} $ \pool -> do + rows <- + runDb pool $ + queryRaw @CountRow (Query "SELECT 1 AS cnt") [] + rows `shouldBe` [CountRow 1] + + it "sql log hook receives the assembled statement with parameters redacted" $ \_ -> do + logs <- newIORef [] + let config = + defaultPool + { poolStripes = 1, + poolMaxPerStripe = 1, + poolSqlLog = \sql -> modifyIORef' logs (sql :) + } + withCustomPool config $ \pool -> do + _ <- + runDb pool $ + queryRaw @CountRow + (Query "SELECT COUNT(*) AS cnt FROM test_widget WHERE name = ?") + [param ("redacted-param" :: Text)] + _ <- + runDb pool $ + executeRaw + (Query "UPDATE test_widget SET name = name WHERE name = ?") + [param ("redacted-param" :: Text)] + _ <- runDb pool (Ops.count @WidgetTable $ matching (eq widgetName "redacted-param")) + pure () + recorded <- reverse <$> readIORef logs + recorded + `shouldSatisfy` any (T.isInfixOf "SELECT COUNT(*) AS cnt FROM test_widget WHERE name = ?") + recorded + `shouldSatisfy` any (T.isInfixOf "UPDATE test_widget SET name = name WHERE name = ?") + recorded + `shouldSatisfy` any (T.isInfixOf "SELECT COUNT(*) FROM \"test_widget\"") + recorded `shouldSatisfy` all (not . T.isInfixOf "redacted-param") diff --git a/test/Poppy/EnumSpec.hs b/test/Poppy/EnumSpec.hs new file mode 100644 --- /dev/null +++ b/test/Poppy/EnumSpec.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE TypeApplications #-} + +module Poppy.EnumSpec + ( enumSpec, + ) +where + +import Poppy (runDb) +import qualified Poppy.AuthorFixtures as AuthorFixtures +import qualified Poppy.Internal.Operations as Ops +import Poppy.Internal.Query (matching) +import Poppy.Internal.Where (eq) +import Schema.Author (AuthorRow (..)) +import Schema.Post (PostRow (..), PostTable, postStatus) +import Schema.PostStatus (PostStatus (..), postStatusToString) +import Support.TestDb (TestEnv (..)) +import Test.Hspec (SpecWith, describe, it, shouldBe, shouldMatchList) + +enumSpec :: SpecWith TestEnv +enumSpec = + describe "schema enums" $ do + it "maps constructors to Postgres labels" $ \_ -> do + postStatusToString Draft `shouldBe` "draft" + postStatusToString Published `shouldBe` "published" + + it "inserts and reads enum columns through FromField/ToField" $ \TestEnv {envPool = pool} -> do + author <- AuthorFixtures.insertAuthor pool "Ada" + draft <- AuthorFixtures.insertPost pool author.id "Notes" Draft + published <- AuthorFixtures.insertPost pool author.id "Essay" Published + draft.status `shouldBe` Draft + published.status `shouldBe` Published + rows <- runDb pool (Ops.findMany @PostTable @PostRow id) + map (.status) rows `shouldMatchList` [Draft, Published] + + it "filters on an enum field" $ \TestEnv {envPool = pool} -> do + author <- AuthorFixtures.insertAuthor pool "Ada" + _ <- AuthorFixtures.insertPost pool author.id "Notes" Draft + _ <- AuthorFixtures.insertPost pool author.id "Essay" Published + rows <- + runDb pool (Ops.findMany @PostTable @PostRow (matching (eq postStatus Published))) + map (.title) rows `shouldBe` ["Essay"] + map (.status) rows `shouldBe` [Published] diff --git a/test/Poppy/ErrorsSpec.hs b/test/Poppy/ErrorsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Poppy/ErrorsSpec.hs @@ -0,0 +1,67 @@ +module Poppy.ErrorsSpec + ( errorsSpec, + ) +where + +import Data.ByteString (ByteString) +import Database.PostgreSQL.Simple (SqlError (..)) +import Poppy.Internal.Errors (DatabaseErrorInfo (..), ORMError (..)) +import Poppy.Internal.Sql (fromSqlError, quoteIdent) +import Test.Hspec (Spec, describe, it, shouldBe) + +errorsSpec :: Spec +errorsSpec = do + describe "Poppy.Internal.Sql.fromSqlError" $ do + it "maps unique violations to UniqueViolation" $ do + fromSqlError sampleUniqueError + `shouldBe` UniqueViolation "duplicate key value violates unique constraint" + + it "maps foreign key violations to ForeignKeyViolation" $ do + fromSqlError sampleFkError + `shouldBe` ForeignKeyViolation "insert or update on table violates foreign key constraint" + + it "maps not-null violations to NotNullViolation" $ do + fromSqlError sampleNotNullError + `shouldBe` NotNullViolation "null value in column violates not-null constraint" + + it "maps other sql errors to DatabaseError" $ do + fromSqlError sampleOtherError + `shouldBe` DatabaseError + DatabaseErrorInfo + { sqlState = "08006", + message = "connection failure", + detail = "" + } + + describe "Poppy.Internal.Sql.quoteIdent" $ do + it "double-quotes identifiers" $ + quoteIdent "recipe" `shouldBe` "\"recipe\"" + + it "escapes embedded quotes" $ + quoteIdent "a\"b" `shouldBe` "\"a\"\"b\"" + +sampleUniqueError :: SqlError +sampleUniqueError = + sampleSqlError "23505" "duplicate key value violates unique constraint" + +sampleFkError :: SqlError +sampleFkError = + sampleSqlError "23503" "insert or update on table violates foreign key constraint" + +sampleNotNullError :: SqlError +sampleNotNullError = + sampleSqlError "23502" "null value in column violates not-null constraint" + +sampleOtherError :: SqlError +sampleOtherError = + sampleSqlError "08006" "connection failure" + +sampleSqlError :: ByteString -> ByteString -> SqlError +sampleSqlError state msg = + SqlError + { sqlState = state, + sqlExecStatus = toEnum 0, + sqlErrorMsg = msg, + sqlErrorDetail = "", + sqlErrorHint = "" + } diff --git a/test/Poppy/GroupSpec.hs b/test/Poppy/GroupSpec.hs new file mode 100644 --- /dev/null +++ b/test/Poppy/GroupSpec.hs @@ -0,0 +1,20 @@ +module Poppy.GroupSpec + ( groupSpec, + ) +where + +import Poppy.Internal.Group (groupByKey) +import Test.Hspec (Spec, describe, it, shouldBe) + +groupSpec :: Spec +groupSpec = + describe "Poppy.Internal.Group.groupByKey" $ do + it "preserves first-seen key order rather than sorted key order" $ do + groupByKey id ([3, 1, 3, 2, 1] :: [Int]) `shouldBe` [[3, 3], [1, 1], [2]] + + it "preserves row order within each group" $ do + groupByKey fst ([('b', 1), ('a', 2), ('b', 3), ('a', 4)] :: [(Char, Int)]) + `shouldBe` [[('b', 1), ('b', 3)], [('a', 2), ('a', 4)]] + + it "returns an empty list for no rows" $ do + groupByKey id ([] :: [Int]) `shouldBe` [] diff --git a/test/Poppy/IncludeFailSpec.hs b/test/Poppy/IncludeFailSpec.hs new file mode 100644 --- /dev/null +++ b/test/Poppy/IncludeFailSpec.hs @@ -0,0 +1,56 @@ +module Poppy.IncludeFailSpec + ( includeFailSpec, + ) +where + +import System.Exit (ExitCode (..)) +import System.Process (readProcessWithExitCode) +import Test.Hspec + +includeFailSpec :: Spec +includeFailSpec = + describe "include type errors" $ do + it "says a skipped field is NotIncluded rather than the row list" $ do + err <- expectFail "include-fail/SkippedChapters.hs" + err `shouldContain` "NotIncluded" + err `shouldContain` "[ChapterRow]" + hidden <- expectFail "include-fail/SkippedChaptersNoSelectors.hs" + hidden `shouldContain` "NotIncluded" + hidden `shouldContain` "[ChapterRow]" + + it "rejects a shelf include nested under books" $ do + err <- expectFail "include-fail/WrongChild.hs" + err `shouldContain` "IncludeFor" + err `shouldContain` "\"Book\"" + err `shouldContain` "ShelfInclude" + + it "rejects a record update when another record in scope shares the field" $ do + err <- expectFail "include-fail/RecordUpdateAmbiguous.hs" + err `shouldContain` "mbiguous" + +expectFail :: FilePath -> IO String +expectFail path = do + (code, _, err) <- + readProcessWithExitCode + "cabal" + ( ["exec", "--", "ghc", "-package", "poppy", "-fno-code", "-w", "-itest", "-outputdir", "/tmp/poppy-include-fail"] + ++ extensions + ++ [path] + ) + "" + case code of + ExitSuccess -> expectationFailure ("expected " <> path <> " to fail") >> pure err + _ -> pure err + +extensions :: [String] +extensions = + [ "-XAllowAmbiguousTypes", + "-XDuplicateRecordFields", + "-XLambdaCase", + "-XNamedFieldPuns", + "-XOverloadedRecordDot", + "-XOverloadedStrings", + "-XScopedTypeVariables", + "-XTypeApplications", + "-XTypeFamilies" + ] diff --git a/test/Poppy/IncludeSpec.hs b/test/Poppy/IncludeSpec.hs new file mode 100644 --- /dev/null +++ b/test/Poppy/IncludeSpec.hs @@ -0,0 +1,335 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeApplications #-} + +module Poppy.IncludeSpec + ( includeSpec, + ) +where + +import Data.List (sort) +import Data.Text (Text) +import qualified Data.Text as T +import Data.UUID (UUID, nil) +import GHC.Records (HasField) +import Poppy (asc, desc, load, loadWith, runDb, skip) +import Poppy.Internal.Include (Load (..)) +import Poppy.IncludeUpdate (updatedChapters) +import qualified Poppy.Internal.Operations as Ops +import qualified Poppy.ShelfFixtures as ShelfFixtures +import Poppy.Internal.Where (eq, neq) +import Schema.Book (BookRow (..), bookId, bookTitle) +import Schema.Chapter (ChapterRow (..)) +import qualified Schema.Client.Book as Book +import qualified Schema.Client.Shelf as Shelf +import Schema.Include.Book (BookInclude (..), BookWith (..)) +import Schema.Include.Chapter (ChapterInclude (..), ChapterWith (..)) +import Schema.Include.Shelf (ShelfInclude (..), ShelfWith (..)) +import Schema.Section (SectionRow (..)) +import Schema.Shelf (ShelfRow (..), ShelfTable, shelfName) +import Schema.Tag (TagRow (..)) +import Support.TestDb (TestEnv (..)) +import Test.Hspec (SpecWith, describe, it, shouldBe) + +includeBooks = + ShelfInclude {books = loadWith (BookInclude {chapters = skip}), tags = skip} + +includeBooksChapters = + ShelfInclude + { books = loadWith (BookInclude {chapters = loadWith (ChapterInclude {sections = skip})}), + tags = skip + } + +includeBooksAndTags = + ShelfInclude {books = loadWith (BookInclude {chapters = skip}), tags = load} + +includeBooksChaptersAndTags = + ShelfInclude + { books = loadWith (BookInclude {chapters = loadWith (ChapterInclude {sections = skip})}), + tags = load + } + +includeBooksChaptersSections = + ShelfInclude + { books = loadWith (BookInclude {chapters = loadWith (ChapterInclude {sections = load})}), + tags = skip + } + +shelves include = Shelf.findMany (Shelf.emptyQuery {Shelf.include_ = include}) + +shelvesWhere include predicate = + Shelf.findMany (Shelf.emptyQuery {Shelf.include_ = include, Shelf.where_ = Just predicate}) + +shelfById include pk = + Shelf.findUnique ((Shelf.uniqueQuery (Shelf.ById pk)) {Shelf.include_ = include}) + +includeSpec :: SpecWith TestEnv +includeSpec = + describe "Poppy.Internal.Include" $ do + it "findMany nests books under their shelf" $ \TestEnv {envPool = pool} -> do + fiction <- ShelfFixtures.insertShelf pool "fiction" + _ <- ShelfFixtures.insertShelf pool "nonfiction" + _ <- ShelfFixtures.insertBook pool fiction.id "Dune" + _ <- ShelfFixtures.insertBook pool fiction.id "Neuromancer" + results <- runDb pool (shelves includeBooks) + length results `shouldBe` 2 + fictionResult <- lookupShelf fiction.id results + let bookIds = map ((.id) . (.book)) fictionResult.books + bookIds `shouldBe` sort bookIds + sort (map ((.title) . (.book)) fictionResult.books) `shouldBe` ["Dune", "Neuromancer"] + + it "findMany includes a shelf with no books as empty list" $ \TestEnv {envPool = pool} -> do + empty <- ShelfFixtures.insertShelf pool "empty" + stocked <- ShelfFixtures.insertShelf pool "stocked" + _ <- ShelfFixtures.insertBook pool stocked.id "Book" + results <- runDb pool (shelves includeBooks) + emptyResult <- lookupShelf empty.id results + length emptyResult.books `shouldBe` 0 + + it "findMany without include uses single-table read" $ \TestEnv {envPool = pool} -> do + _ <- ShelfFixtures.insertShelf pool "alpha" + _ <- ShelfFixtures.insertShelf pool "beta" + results <- runDb pool (Ops.findMany @ShelfTable @ShelfRow id) + length results `shouldBe` 2 + sort (map (.name) results) `shouldBe` ["alpha", "beta"] + + it "findMany returns included roots in primary-key order" $ \TestEnv {envPool = pool} -> do + firstShelf <- ShelfFixtures.insertShelf pool "first" + secondShelf <- ShelfFixtures.insertShelf pool "second" + results <- runDb pool (shelves includeBooks) + map ((.id) . (.shelf)) results `shouldBe` sort [firstShelf.id, secondShelf.id] + + it "findMany applies root filter before nesting" $ \TestEnv {envPool = pool} -> do + fiction <- ShelfFixtures.insertShelf pool "fiction" + _ <- ShelfFixtures.insertShelf pool "nonfiction" + _ <- ShelfFixtures.insertBook pool fiction.id "Dune" + results <- + runDb pool (shelvesWhere includeBooks (eq shelfName "fiction")) + length results `shouldBe` 1 + (head results).shelf.name `shouldBe` "fiction" + map ((.title) . (.book)) (head results).books `shouldBe` ["Dune"] + + it "findMany nests chapters under books" $ \TestEnv {envPool = pool} -> do + shelf <- ShelfFixtures.insertShelf pool "fiction" + book <- ShelfFixtures.insertBook pool shelf.id "Dune" + _ <- ShelfFixtures.insertChapter pool book.id "Arrakis" + _ <- ShelfFixtures.insertChapter pool book.id "Caladan" + results <- runDb pool (shelves includeBooksChapters) + [result] <- pure results + result.shelf.name `shouldBe` "fiction" + [bookWithChapters] <- pure result.books + (.title) bookWithChapters.book `shouldBe` "Dune" + let chapterIds = map ((.id) . (.chapter)) bookWithChapters.chapters + chapterIds `shouldBe` sort chapterIds + sort (map ((.heading) . (.chapter)) bookWithChapters.chapters) `shouldBe` ["Arrakis", "Caladan"] + + it "findMany includes a book with no chapters as empty list" $ \TestEnv {envPool = pool} -> do + shelf <- ShelfFixtures.insertShelf pool "fiction" + book <- ShelfFixtures.insertBook pool shelf.id "Dune" + _ <- ShelfFixtures.insertBook pool shelf.id "Neuromancer" + _ <- ShelfFixtures.insertChapter pool book.id "Chiba" + results <- runDb pool (shelves includeBooksChapters) + [result] <- pure results + dune <- lookupBook "Dune" result + neuromancer <- lookupBook "Neuromancer" result + map ((.heading) . (.chapter)) dune.chapters `shouldBe` ["Chiba"] + length neuromancer.chapters `shouldBe` 0 + + it "findMany returns all nested results" $ \TestEnv {envPool = pool} -> do + _ <- ShelfFixtures.insertShelf pool "one" + _ <- ShelfFixtures.insertShelf pool "two" + results <- runDb pool (shelves includeBooks) + length results `shouldBe` 2 + + it "findUnique returns Just for an existing primary key" $ \TestEnv {envPool = pool} -> do + shelf <- ShelfFixtures.insertShelf pool "fiction" + _ <- ShelfFixtures.insertBook pool shelf.id "Dune" + Right result <- runDb pool (shelfById includeBooks shelf.id) + fmap ((.name) . (.shelf)) result `shouldBe` Just "fiction" + + it "findUnique returns all children for a parent with several has-many rows" $ \TestEnv {envPool = pool} -> do + shelf <- ShelfFixtures.insertShelf pool "fiction" + _ <- ShelfFixtures.insertBook pool shelf.id "Dune" + _ <- ShelfFixtures.insertBook pool shelf.id "Neuromancer" + Right result <- runDb pool (shelfById includeBooks shelf.id) + let bookIds = maybe [] (map ((.id) . (.book)) . (.books)) result + bookIds `shouldBe` sort bookIds + fmap (sort . map ((.title) . (.book)) . (.books)) result + `shouldBe` Just ["Dune", "Neuromancer"] + + it "findUnique includes a shelf with no books as Just with an empty list" $ \TestEnv {envPool = pool} -> do + empty <- ShelfFixtures.insertShelf pool "empty" + Right result <- runDb pool (shelfById includeBooks empty.id) + fmap ((.name) . (.shelf)) result `shouldBe` Just "empty" + fmap (length . (.books)) result `shouldBe` Just 0 + + it "findUnique returns Nothing when missing" $ \TestEnv {envPool = pool} -> do + Right result <- runDb pool (shelfById includeBooks (nil :: UUID)) + case result of + Nothing -> pure () + Just _ -> fail "expected Nothing" + + it "findMany with include paginates parent rows" $ \TestEnv {envPool = pool} -> do + mapM_ (\n -> ShelfFixtures.insertShelf pool ("shelf-" `T.append` T.pack (show n))) ([1 .. 12] :: [Int]) + results <- + runDb + pool + (Shelf.findMany (Shelf.emptyQuery {Shelf.include_ = includeBooks, Shelf.limit_ = Just 10})) + length results `shouldBe` 10 + + it "findMany with include applies offset to parent rows" $ \TestEnv {envPool = pool} -> do + _ <- ShelfFixtures.insertShelf pool "alpha" + _ <- ShelfFixtures.insertShelf pool "bravo" + _ <- ShelfFixtures.insertShelf pool "charlie" + results <- + runDb + pool + ( Shelf.findMany + Shelf.emptyQuery + { Shelf.include_ = includeBooks, + Shelf.orderBy_ = [asc shelfName], + Shelf.limit_ = Just 1, + Shelf.offset_ = Just 1 + } + ) + length results `shouldBe` 1 + (head results).shelf.name `shouldBe` "bravo" + + it "findMany with include orders parent rows" $ \TestEnv {envPool = pool} -> do + _ <- ShelfFixtures.insertShelf pool "zeta" + _ <- ShelfFixtures.insertShelf pool "alpha" + results <- + runDb + pool + (Shelf.findMany (Shelf.emptyQuery {Shelf.include_ = includeBooks, Shelf.orderBy_ = [asc shelfName]})) + map ((.name) . (.shelf)) results `shouldBe` ["alpha", "zeta"] + + it "findMany loads sibling hasMany collections independently" $ \TestEnv {envPool = pool} -> do + shelf <- ShelfFixtures.insertShelf pool "fiction" + _ <- ShelfFixtures.insertBook pool shelf.id "Dune" + _ <- ShelfFixtures.insertBook pool shelf.id "Neuromancer" + _ <- ShelfFixtures.insertTag pool shelf.id "scifi" + _ <- ShelfFixtures.insertTag pool shelf.id "classic" + results <- runDb pool (shelves includeBooksAndTags) + [result] <- pure results + sort (map ((.title) . (.book)) result.books) `shouldBe` ["Dune", "Neuromancer"] + sort (map (.label) result.tags) `shouldBe` ["classic", "scifi"] + + it "findMany combines nested books with sibling tags" $ \TestEnv {envPool = pool} -> do + shelf <- ShelfFixtures.insertShelf pool "fiction" + book <- ShelfFixtures.insertBook pool shelf.id "Dune" + _ <- ShelfFixtures.insertChapter pool book.id "Arrakis" + _ <- ShelfFixtures.insertTag pool shelf.id "scifi" + results <- runDb pool (shelves includeBooksChaptersAndTags) + [result] <- pure results + [bookWithChapters] <- pure result.books + (.title) bookWithChapters.book `shouldBe` "Dune" + map ((.heading) . (.chapter)) bookWithChapters.chapters `shouldBe` ["Arrakis"] + map (.label) result.tags `shouldBe` ["scifi"] + + it "findMany nests sections under chapters at four levels deep" $ \TestEnv {envPool = pool} -> do + shelf <- ShelfFixtures.insertShelf pool "fiction" + book <- ShelfFixtures.insertBook pool shelf.id "Dune" + chapter <- ShelfFixtures.insertChapter pool book.id "Arrakis" + _ <- ShelfFixtures.insertSection pool chapter.id "Desert" + _ <- ShelfFixtures.insertSection pool chapter.id "Sietch" + results <- runDb pool (shelves includeBooksChaptersSections) + [result] <- pure results + [bookWithChapters] <- pure result.books + [chapterWithSections] <- pure bookWithChapters.chapters + let sectionIds = map (.id) chapterWithSections.sections + sectionIds `shouldBe` sort sectionIds + sort (map (.label) chapterWithSections.sections) `shouldBe` ["Desert", "Sietch"] + + it "one renderer accepts a book loaded on its own and under a shelf" $ \TestEnv {envPool = pool} -> do + shelf <- ShelfFixtures.insertShelf pool "fiction" + book <- ShelfFixtures.insertBook pool shelf.id "Dune" + _ <- ShelfFixtures.insertChapter pool book.id "Arrakis" + let bookInclude = BookInclude {chapters = load} + [fromBook] <- + runDb + pool + (Book.findMany (Book.emptyQuery {Book.include_ = bookInclude, Book.where_ = Just (eq bookId book.id)})) + [fromShelf] <- + runDb + pool + (shelves (ShelfInclude {books = loadWith bookInclude, tags = skip})) + renderBook fromBook `shouldBe` ["Arrakis"] + renderBook (head fromShelf.books) `shouldBe` ["Arrakis"] + + it "updates a book include from the caller when the field name is unique" $ \_ -> + updatedChapters `shouldBe` load + + it "findMany includes only books matching where_" $ \TestEnv {envPool = pool} -> do + fiction <- ShelfFixtures.insertShelf pool "fiction" + mystery <- ShelfFixtures.insertShelf pool "mystery" + _ <- ShelfFixtures.insertBook pool fiction.id "Dune" + _ <- ShelfFixtures.insertBook pool fiction.id "Neuromancer" + _ <- ShelfFixtures.insertBook pool mystery.id "Rebecca" + let include = + ShelfInclude + { books = + (loadWith (BookInclude {chapters = skip})) + { where_ = Just (eq bookTitle "Dune") + }, + tags = skip + } + results <- runDb pool (shelves include) + fictionResult <- lookupShelf fiction.id results + mysteryResult <- lookupShelf mystery.id results + map ((.title) . (.book)) fictionResult.books `shouldBe` ["Dune"] + length mysteryResult.books `shouldBe` 0 + + it "findMany orders included books" $ \TestEnv {envPool = pool} -> do + shelf <- ShelfFixtures.insertShelf pool "fiction" + _ <- ShelfFixtures.insertBook pool shelf.id "Neuromancer" + _ <- ShelfFixtures.insertBook pool shelf.id "Dune" + _ <- ShelfFixtures.insertBook pool shelf.id "Contact" + let include = + ShelfInclude + { books = + (loadWith (BookInclude {chapters = skip})) + { orderBy_ = [desc bookTitle] + }, + tags = skip + } + results <- runDb pool (shelves include) + [result] <- pure results + map ((.title) . (.book)) result.books `shouldBe` ["Neuromancer", "Dune", "Contact"] + + it "findMany takes two ordered books per shelf" $ \TestEnv {envPool = pool} -> do + empty <- ShelfFixtures.insertShelf pool "empty" + fiction <- ShelfFixtures.insertShelf pool "fiction" + history <- ShelfFixtures.insertShelf pool "history" + mapM_ (ShelfFixtures.insertBook pool fiction.id) ["alpha", "bravo", "charlie", "zzz"] + mapM_ (ShelfFixtures.insertBook pool history.id) ["m", "n", "zzz"] + let include = + ShelfInclude + { books = + (loadWith (BookInclude {chapters = skip})) + { where_ = Just (neq bookTitle "zzz"), + orderBy_ = [asc bookTitle], + take_ = Just 2 + }, + tags = skip + } + results <- runDb pool (shelves include) + emptyResult <- lookupShelf empty.id results + fictionResult <- lookupShelf fiction.id results + historyResult <- lookupShelf history.id results + length emptyResult.books `shouldBe` 0 + map ((.title) . (.book)) fictionResult.books `shouldBe` ["alpha", "bravo"] + map ((.title) . (.book)) historyResult.books `shouldBe` ["m", "n"] + +renderBook :: (HasField "chapters" row [ChapterRow]) => row -> [Text] +renderBook row = map (.heading) row.chapters + +lookupShelf wanted results = + case filter ((== wanted) . (.id) . (.shelf)) results of + [shelf] -> pure shelf + _ -> fail "expected exactly one shelf in results" + +lookupBook title result = + case filter ((== title) . (.title) . (.book)) result.books of + [book] -> pure book + _ -> fail "expected exactly one book in results" diff --git a/test/Poppy/IncludeUpdate.hs b/test/Poppy/IncludeUpdate.hs new file mode 100644 --- /dev/null +++ b/test/Poppy/IncludeUpdate.hs @@ -0,0 +1,14 @@ +module Poppy.IncludeUpdate + ( updatedChapters, + ) +where + +import Poppy (load, skip) +import Poppy.Internal.Include (Load) +import Schema.Chapter (ChapterTable) +import Schema.Include.Book (BookInclude (..)) + +updatedChapters :: Load ChapterTable () +updatedChapters = + let BookInclude {chapters} = BookInclude {chapters = skip} {chapters = load} + in chapters diff --git a/test/Poppy/MigrateSpec.hs b/test/Poppy/MigrateSpec.hs new file mode 100644 --- /dev/null +++ b/test/Poppy/MigrateSpec.hs @@ -0,0 +1,111 @@ +module Poppy.MigrateSpec + ( migrateSpec, + ) +where + +import Control.Exception (bracket) +import Data.Int (Int64) +import Data.Text (Text) +import qualified Data.Text.IO as TIO +import Data.UUID.V4 (nextRandom) +import Database.PostgreSQL.Simple (Only (..)) +import qualified Database.PostgreSQL.Simple as PG +import Poppy (MigrateError (..), applyMigrations) +import Poppy.Internal.Db (DbPool, withConn) +import Support.TestDb (TestEnv (..)) +import System.Directory (createDirectoryIfMissing, getTemporaryDirectory, removeDirectoryRecursive) +import System.FilePath (()) +import Test.Hspec (SpecWith, describe, it, shouldBe, shouldSatisfy) + +migrateSpec :: SpecWith TestEnv +migrateSpec = + describe "Poppy.Internal.Migrate" $ do + it "applies SQL files in name order and is a no-op on replay" $ \TestEnv {envPool = pool} -> + withCleanProbe pool + $ withMigrationDir + [ ("notes.txt", "not sql"), + ("002-add-label.sql", "ALTER TABLE _poppy_phase10_probe ADD COLUMN label TEXT;"), + ("001-create.sql", "CREATE TABLE _poppy_phase10_probe (id INT PRIMARY KEY);") + ] + $ \dir -> do + first <- applyMigrations pool dir + first `shouldBe` Right ["001-create.sql", "002-add-label.sql"] + columns <- probeColumns pool + columns `shouldBe` 2 + second <- applyMigrations pool dir + second `shouldBe` Right [] + probeColumns pool >>= (`shouldBe` 2) + + it "does not record a failed file" $ \TestEnv {envPool = pool} -> + withCleanProbe pool + $ withMigrationDir + [ ("001-ok.sql", "CREATE TABLE _poppy_phase10_probe (id INT PRIMARY KEY);"), + ("002-bad.sql", "SELECT * FROM definitely_not_a_poppy_migrate_table;") + ] + $ \dir -> do + result <- applyMigrations pool dir + result + `shouldSatisfy` ( \case + Left (MigrateFailed "002-bad.sql" _) -> True + _ -> False + ) + recorded <- recordedNames pool + recorded `shouldBe` ["001-ok.sql"] + exists <- probeExists pool + exists `shouldBe` True + + it "returns DirectoryError when the path is not a directory" $ \TestEnv {envPool = pool} -> do + result <- applyMigrations pool "/definitely-not-a-poppy-migrate-dir" + result + `shouldSatisfy` ( \case + Left (MigrateDirectoryError _) -> True + _ -> False + ) + +withCleanProbe :: DbPool -> IO a -> IO a +withCleanProbe pool action = dropProbeState pool >> action <* dropProbeState pool + +dropProbeState :: DbPool -> IO () +dropProbeState pool = + withConn pool $ \conn -> do + _ <- PG.execute_ conn "DROP TABLE IF EXISTS _poppy_phase10_probe CASCADE" + _ <- PG.execute_ conn "DROP TABLE IF EXISTS _poppy_migrations CASCADE" + pure () + +withMigrationDir :: [(FilePath, Text)] -> (FilePath -> IO a) -> IO a +withMigrationDir files action = do + tmp <- getTemporaryDirectory + token <- nextRandom + let dir = tmp ("poppy-migrate-" <> show token) + bracket + (createDirectoryIfMissing True dir >> pure dir) + removeDirectoryRecursive + ( \dir -> do + mapM_ (\(name, body) -> TIO.writeFile (dir name) body) files + action dir + ) + +probeExists :: DbPool -> IO Bool +probeExists pool = + withConn pool $ \conn -> do + [Only exists] <- + PG.query_ + conn + "SELECT to_regclass('public._poppy_phase10_probe') IS NOT NULL" + pure exists + +probeColumns :: DbPool -> IO Int64 +probeColumns pool = + withConn pool $ \conn -> do + [Only n] <- + PG.query_ + conn + "SELECT COUNT(*) FROM information_schema.columns \ + \WHERE table_schema = 'public' AND table_name = '_poppy_phase10_probe'" + pure n + +recordedNames :: DbPool -> IO [Text] +recordedNames pool = + withConn pool $ \conn -> do + rows <- PG.query_ conn "SELECT name FROM _poppy_migrations ORDER BY name" + pure [name | Only name <- rows] diff --git a/test/Poppy/NestedWriteSpec.hs b/test/Poppy/NestedWriteSpec.hs new file mode 100644 --- /dev/null +++ b/test/Poppy/NestedWriteSpec.hs @@ -0,0 +1,345 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE TypeApplications #-} + +module Poppy.NestedWriteSpec + ( nestedWriteSpec, + ) +where + +import Data.List (sort) +import qualified Data.UUID.V4 as V4 +import Poppy (NullableValue (Omit), ORMError (..), load, loadWith, runDb, skip) +import qualified Poppy.Internal.Operations as Ops +import Schema.Book (BookRow (..), BookTable, BookUpdate (..)) +import qualified Schema.Client.Book as Book +import qualified Schema.Client.Comment as Comment +import qualified Schema.Client.Shelf as Shelf +import Schema.Comment (CommentRow (..), CommentTable) +import Schema.Include.Book (BookInclude (..), BookWith (..)) +import Schema.Include.Shelf (ShelfInclude (..), ShelfWith (..)) +import Schema.Shelf (ShelfRow (..), ShelfTable) +import Support.Assert (assertRight) +import Support.TestDb (TestEnv (..)) +import Test.Hspec (SpecWith, describe, expectationFailure, it, shouldBe, shouldMatchList) + +nestedWriteSpec :: SpecWith TestEnv +nestedWriteSpec = + describe "nested writes" $ do + it "create inserts a parent and children in one transaction" $ \TestEnv {envPool = pool} -> do + result <- + runDb + pool + ( Shelf.create + Shelf.ShelfCreate + { id = Nothing, + name = "fiction", + books = + [ Shelf.CreateBook {id = Nothing, title = "Dune"}, + Shelf.CreateBook {id = Nothing, title = "Neuromancer"} + ], + tags = [] + } + ) + >>= assertRight + result.name `shouldBe` "fiction" + books <- runDb pool (Ops.findMany @BookTable @BookRow id) + sort (map (.title) books) `shouldBe` ["Dune", "Neuromancer"] + + it "replaceWith replaces all children" $ \TestEnv {envPool = pool} -> do + created <- + runDb + pool + ( Shelf.create + Shelf.ShelfCreate + { id = Nothing, + name = "fiction", + books = + [ Shelf.CreateBook {id = Nothing, title = "Dune"}, + Shelf.CreateBook {id = Nothing, title = "Neuromancer"} + ], + tags = [] + } + ) + >>= assertRight + _ <- + runDb + pool + ( Shelf.update + (Shelf.ById created.id) + Shelf.ShelfUpdate + { name = Nothing, + books = Just (booksReplace [Shelf.CreateBook {id = Nothing, title = "Hyperion"}]), + tags = Nothing + } + ) + >>= assertRight + books <- runDb pool (Ops.findMany @BookTable @BookRow id) + map (.title) books `shouldBe` ["Hyperion"] + + it "create on update adds a child without wiping existing ones" $ \TestEnv {envPool = pool} -> do + created <- + runDb + pool + ( Shelf.create + Shelf.ShelfCreate + { id = Nothing, + name = "fiction", + books = [Shelf.CreateBook {id = Nothing, title = "Dune"}], + tags = [] + } + ) + >>= assertRight + _ <- + runDb + pool + ( Shelf.update + (Shelf.ById created.id) + Shelf.ShelfUpdate + { name = Nothing, + books = Just (booksCreate [Shelf.CreateBook {id = Nothing, title = "Neuromancer"}]), + tags = Nothing + } + ) + >>= assertRight + remaining <- runDb pool (Ops.findMany @BookTable @BookRow id) + sort (map (.title) remaining) `shouldBe` ["Dune", "Neuromancer"] + + it "delete removes a child by unique key" $ \TestEnv {envPool = pool} -> do + created <- + runDb + pool + ( Shelf.create + Shelf.ShelfCreate + { id = Nothing, + name = "fiction", + books = + [ Shelf.CreateBook {id = Nothing, title = "Dune"}, + Shelf.CreateBook {id = Nothing, title = "Neuromancer"} + ], + tags = [] + } + ) + >>= assertRight + loaded <- + runDb + pool + (Shelf.findUnique ((Shelf.uniqueQuery (Shelf.ById created.id)) {Shelf.include_ = shelfInclude})) + >>= assertRight + let duneId = + case loaded of + Nothing -> error "expected shelf" + Just shelf -> + head [b.book.id | b <- shelf.books, b.book.title == "Dune"] + _ <- + runDb + pool + ( Shelf.update + (Shelf.ById created.id) + Shelf.ShelfUpdate + { name = Nothing, + books = Just (booksDelete [Book.ById duneId]), + tags = Nothing + } + ) + >>= assertRight + remaining <- runDb pool (Ops.findMany @BookTable @BookRow id) + map (.title) remaining `shouldBe` ["Neuromancer"] + + it "disconnect keeps the child and clears a nullable FK" $ \TestEnv {envPool = pool} -> do + parent <- + runDb + pool + ( Comment.create + Comment.CommentCreate + { id = Nothing, + parentId = Omit, + body = "parent", + replies = [] + } + ) + >>= assertRight + child <- + runDb + pool + ( Comment.create + Comment.CommentCreate + { id = Nothing, + parentId = Omit, + body = "child", + replies = [] + } + ) + >>= assertRight + _ <- + runDb + pool + ( Comment.update + (Comment.ById parent.id) + Comment.CommentUpdate + { parentId = Omit, + body = Nothing, + replies = Just (repliesConnect [Comment.ById child.id]) + } + ) + >>= assertRight + _ <- + runDb + pool + ( Comment.update + (Comment.ById parent.id) + Comment.CommentUpdate + { parentId = Omit, + body = Nothing, + replies = Just (repliesDisconnect [Comment.ById child.id]) + } + ) + >>= assertRight + remaining <- runDb pool (Ops.findMany @CommentTable @CommentRow id) + sort (map (.body) remaining) `shouldMatchList` ["child", "parent"] + let childRow = head [c | c <- remaining, c.body == "child"] + childRow.parentId `shouldBe` Nothing + + it "upsert does not steal another parent's child" $ \TestEnv {envPool = pool} -> do + shelfA <- + runDb + pool + ( Shelf.create + Shelf.ShelfCreate + { id = Nothing, + name = "a", + books = [Shelf.CreateBook {id = Nothing, title = "Owned"}], + tags = [] + } + ) + >>= assertRight + shelfB <- + runDb + pool + ( Shelf.create + Shelf.ShelfCreate {id = Nothing, name = "b", books = [], tags = []} + ) + >>= assertRight + owned <- runDb pool (Ops.findMany @BookTable @BookRow id) + let bookId = head [b.id | b <- owned, b.title == "Owned"] + result <- + runDb + pool + ( Shelf.update + (Shelf.ById shelfB.id) + Shelf.ShelfUpdate + { name = Nothing, + books = + Just + ( booksUpsert + [ Shelf.BookNestedUpsert + { where_ = Book.ById bookId, + create = Shelf.CreateBook {id = Nothing, title = "Stolen"}, + update = BookUpdate {shelfId = Nothing, title = Just "Stolen"} + } + ] + ), + tags = Nothing + } + ) + case result of + Left (UniqueViolation _) -> pure () + Left other -> expectationFailure ("expected UniqueViolation, got " <> show other) + Right _ -> expectationFailure "expected UniqueViolation when upsert would reparent" + remaining <- runDb pool (Ops.findMany @BookTable @BookRow id) + map (.shelfId) remaining `shouldBe` [shelfA.id] + map (.title) remaining `shouldBe` ["Owned"] + + it "create rolls back the parent when a child write fails" $ \TestEnv {envPool = pool} -> do + fixed <- V4.nextRandom + result <- + runDb pool $ + Shelf.create + Shelf.ShelfCreate + { id = Nothing, + name = "rollback", + books = + [ Shelf.CreateBook {id = Just fixed, title = "Lost"}, + Shelf.CreateBook {id = Just fixed, title = "Dup"} + ], + tags = [] + } + case result of + Left (UniqueViolation _) -> pure () + Left other -> expectationFailure ("expected UniqueViolation, got " <> show other) + Right _ -> expectationFailure "expected UniqueViolation, got a written shelf" + shelves <- runDb pool (Ops.findMany @ShelfTable @ShelfRow id) + books <- runDb pool (Ops.findMany @BookTable @BookRow id) + shelves `shouldBe` [] + books `shouldBe` [] + +booksReplace xs = + Shelf.BooksUpdate + { replaceWith = Just xs, + create = [], + createMany = [], + connect = [], + delete = [], + update = [], + upsert = [] + } + +booksCreate xs = + Shelf.BooksUpdate + { replaceWith = Nothing, + create = xs, + createMany = [], + connect = [], + delete = [], + update = [], + upsert = [] + } + +booksDelete keys = + Shelf.BooksUpdate + { replaceWith = Nothing, + create = [], + createMany = [], + connect = [], + delete = keys, + update = [], + upsert = [] + } + +booksUpsert items = + Shelf.BooksUpdate + { replaceWith = Nothing, + create = [], + createMany = [], + connect = [], + delete = [], + update = [], + upsert = items + } + +repliesConnect keys = + Comment.RepliesUpdate + { replaceWith = Nothing, + create = [], + createMany = [], + connect = keys, + delete = [], + update = [], + upsert = [], + disconnect = [] + } + +repliesDisconnect keys = + Comment.RepliesUpdate + { replaceWith = Nothing, + create = [], + createMany = [], + connect = [], + delete = [], + update = [], + upsert = [], + disconnect = keys + } + +shelfInclude = + ShelfInclude {books = loadWith (BookInclude {chapters = skip}), tags = skip} diff --git a/test/Poppy/OperationsSpec.hs b/test/Poppy/OperationsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Poppy/OperationsSpec.hs @@ -0,0 +1,336 @@ +{-# LANGUAGE LambdaCase #-} + +module Poppy.OperationsSpec + ( operationsSpec, + ) +where + +import Data.List (sort) +import Data.UUID (UUID, nil) +import Poppy (NullableValue (..), ORMError (..), runDb) +import qualified Poppy.Internal.Delete as Delete +import qualified Poppy.Internal.Insert as Insert +import qualified Poppy.Internal.Operations as Ops +import Poppy.Internal.Query (OrderDirection (Asc), limit, matching, offset, orderBy) +import qualified Poppy.Internal.Update as Update +import Poppy.Internal.Where (contains, eq, in_, isNull, or_) +import qualified Poppy.WidgetFixtures as WidgetFixtures +import Schema.Book (BookCreate (..), BookRow (..), BookTable) +import Schema.Widget (WidgetCreate (..), WidgetRow (..), WidgetTable (..), WidgetUpdate (..), widgetCreatedAt, widgetDescription, widgetId, widgetName) +import Support.Assert (assertJust, assertRight) +import Support.TestDb (TestEnv (..)) +import Test.Hspec (SpecWith, describe, it, shouldBe, shouldSatisfy) + +operationsSpec :: SpecWith TestEnv +operationsSpec = + describe "Poppy.Internal.Operations" $ do + it "findMany returns an empty list on a clean test_widget table" $ \TestEnv {envPool = pool} -> do + rows <- runDb pool (Ops.findMany @WidgetTable @WidgetRow id) + rows `shouldBe` [] + + it "findMany returns all rows in table" $ \TestEnv {envPool = pool} -> do + alpha <- WidgetFixtures.insertWidget pool "alpha" + beta <- WidgetFixtures.insertWidget pool "beta" + gamma <- WidgetFixtures.insertWidget pool "gamma" + results <- runDb pool (Ops.findMany @WidgetTable @WidgetRow id) + sort (map (.id) results) `shouldBe` sort [alpha.id, beta.id, gamma.id] + + it "findUnique returns an element by id" $ \TestEnv {envPool = pool} -> do + widget <- WidgetFixtures.insertWidget pool "test" + result <- runDb pool (Ops.findUnique @WidgetTable @WidgetRow widget.id) + result `shouldBe` Just widget + + it "findMany returns all elements that pass the filter" $ \TestEnv {envPool = pool} -> do + alpha1 <- insertDescribed pool "alpha-1" "pair" + alpha2 <- insertDescribed pool "alpha-2" "pair" + _ <- WidgetFixtures.insertWidget pool "beta" + results <- runDb pool (Ops.findMany @WidgetTable @WidgetRow $ matching (eq widgetDescription "pair")) + sort (map (.id) results) `shouldBe` sort [alpha1.id, alpha2.id] + + it "findUniqueOrFail returns an element by id" $ \TestEnv {envPool = pool} -> do + widget <- WidgetFixtures.insertWidget pool "test" + result <- runDb pool (Ops.findUniqueOrFail @WidgetTable @WidgetRow widget.id) + result `shouldBe` Right widget + + it "findUniqueOrFail returns an error if no element is found" $ \TestEnv {envPool = pool} -> do + result <- runDb pool (Ops.findUniqueOrFail @WidgetTable @WidgetRow (nil :: UUID)) + result + `shouldSatisfy` ( \case + Left (RecordNotFound _) -> True + _ -> False + ) + + it "findFirst returns the first element that passes the filter" $ \TestEnv {envPool = pool} -> do + alpha1 <- insertDescribed pool "alpha-1" "pair" + alpha2 <- insertDescribed pool "alpha-2" "pair" + _ <- WidgetFixtures.insertWidget pool "beta" + result <- runDb pool (Ops.findFirst @WidgetTable @WidgetRow $ matching (eq widgetDescription "pair")) + row <- assertJust result + row.description `shouldBe` Just "pair" + row.id `shouldSatisfy` (`elem` [alpha1.id, alpha2.id]) + + it "findFirst returns Nothing when no row matches" $ \TestEnv {envPool = pool} -> do + result <- runDb pool (Ops.findFirst @WidgetTable @WidgetRow $ matching (eq widgetName "nonexistent")) + result `shouldBe` Nothing + + it "count returns the number of rows matching a filter" $ \TestEnv {envPool = pool} -> do + _ <- insertDescribed pool "alpha-1" "pair" + _ <- insertDescribed pool "alpha-2" "pair" + _ <- WidgetFixtures.insertWidget pool "beta" + n <- runDb pool (Ops.count @WidgetTable $ matching (eq widgetDescription "pair")) + n `shouldBe` 2 + + it "count returns 0 when no rows match" $ \TestEnv {envPool = pool} -> do + n <- runDb pool (Ops.count @WidgetTable $ matching (eq widgetName "nonexistent")) + n `shouldBe` 0 + + it "update changes a widget name by id" $ \TestEnv {envPool = pool} -> do + widget <- WidgetFixtures.insertWidget pool "before" + updated <- + runDb + pool + ( Update.update @WidgetTable @WidgetRow + widget.id + WidgetUpdate + { name = Just "after", + createdAt = Nothing, + updatedAt = Nothing, + description = Omit + } + ) + >>= assertRight + updated.name `shouldBe` "after" + found <- runDb pool (Ops.findUnique @WidgetTable @WidgetRow widget.id) + found `shouldBe` Just updated + + it "update with Omit leaves description unchanged" $ \TestEnv {envPool = pool} -> do + widget <- + runDb + pool + ( Insert.insert @WidgetTable @WidgetRow + WidgetCreate + { id = Nothing, + createdAt = Nothing, + updatedAt = Nothing, + name = "widget", + description = Value "keep me" + } + ) + >>= assertRight + updated <- + runDb + pool + ( Update.update @WidgetTable @WidgetRow + widget.id + WidgetUpdate + { name = Just "renamed", + createdAt = Nothing, + updatedAt = Nothing, + description = Omit + } + ) + >>= assertRight + updated.name `shouldBe` "renamed" + updated.description `shouldBe` Just "keep me" + + it "insert with Null sets description to NULL" $ \TestEnv {envPool = pool} -> do + widget <- + runDb + pool + ( Insert.insert @WidgetTable @WidgetRow + WidgetCreate + { id = Nothing, + createdAt = Nothing, + updatedAt = Nothing, + name = "widget", + description = Null + } + ) + >>= assertRight + widget.description `shouldBe` Nothing + + it "update with Null clears description" $ \TestEnv {envPool = pool} -> do + widget <- + runDb + pool + ( Insert.insert @WidgetTable @WidgetRow + WidgetCreate + { id = Nothing, + createdAt = Nothing, + updatedAt = Nothing, + name = "widget", + description = Value "keep me" + } + ) + >>= assertRight + updated <- + runDb + pool + ( Update.update @WidgetTable @WidgetRow + widget.id + WidgetUpdate + { name = Nothing, + createdAt = Nothing, + updatedAt = Nothing, + description = Null + } + ) + >>= assertRight + updated.description `shouldBe` Nothing + + it "findMany supports offset" $ \TestEnv {envPool = pool} -> do + _ <- insertDescribed pool "alpha-1" "page" + _ <- insertDescribed pool "alpha-2" "page" + _ <- insertDescribed pool "alpha-3" "page" + allAlpha <- runDb pool (Ops.findMany @WidgetTable @WidgetRow $ matching (eq widgetDescription "page")) + paged <- + runDb + pool + ( Ops.findMany @WidgetTable @WidgetRow $ + offset 1 . limit 1 . orderBy widgetCreatedAt Asc . matching (eq widgetDescription "page") + ) + length allAlpha `shouldBe` 3 + length paged `shouldBe` 1 + + it "delete removes a widget by id" $ \TestEnv {envPool = pool} -> do + widget <- WidgetFixtures.insertWidget pool "doomed" + deleted <- runDb pool (Ops.delete @WidgetTable widget.id) >>= assertRight + deleted `shouldBe` 1 + found <- runDb pool (Ops.findUnique @WidgetTable @WidgetRow widget.id) + found `shouldBe` Nothing + + it "delete returns 0 when no row matches" $ \TestEnv {envPool = pool} -> do + deleted <- runDb pool (Ops.delete @WidgetTable (nil :: UUID)) >>= assertRight + deleted `shouldBe` 0 + + it "deleteWhere without WHERE returns EmptyWhere" $ \TestEnv {envPool = pool} -> do + result <- runDb pool (Delete.deleteWhere (Delete.emptyDelete @WidgetTable)) + result + `shouldSatisfy` ( \case + Left (EmptyWhere _) -> True + _ -> False + ) + + it "deleteReturning without WHERE returns EmptyWhere" $ \TestEnv {envPool = pool} -> do + result <- + runDb + pool + (Delete.deleteReturning @WidgetTable @WidgetRow (Delete.emptyDelete @WidgetTable)) + result + `shouldSatisfy` ( \case + Left (EmptyWhere _) -> True + _ -> False + ) + + it "updateReturning without WHERE returns EmptyWhere" $ \TestEnv {envPool = pool} -> do + result <- + runDb + pool + ( Update.updateReturning @WidgetTable @WidgetRow $ + Update.setField widgetName "x" (Update.emptyUpdate @WidgetTable) + ) + result + `shouldSatisfy` ( \case + Left (EmptyWhere _) -> True + _ -> False + ) + + it "deleteMany removes rows matching a Where predicate" $ \TestEnv {envPool = pool} -> do + _ <- WidgetFixtures.insertWidget pool "doomed" + _ <- WidgetFixtures.insertWidget pool "keep" + deleted <- runDb pool (Delete.deleteMany @WidgetTable (eq widgetName "doomed")) >>= assertRight + deleted `shouldBe` 1 + remaining <- runDb pool (Ops.findMany @WidgetTable @WidgetRow id) + map (.name) remaining `shouldBe` ["keep"] + + it "findMany contains matches a substring case-insensitively" $ \TestEnv {envPool = pool} -> do + _ <- WidgetFixtures.insertWidget pool "Sea Salt" + _ <- WidgetFixtures.insertWidget pool "pepper" + results <- runDb pool (Ops.findMany @WidgetTable @WidgetRow $ matching (contains widgetName "salt")) + map (.name) results `shouldBe` ["Sea Salt"] + + it "findMany isNull matches NULL description" $ \TestEnv {envPool = pool} -> do + widget <- WidgetFixtures.insertWidget pool "blank" + results <- runDb pool (Ops.findMany @WidgetTable @WidgetRow $ matching (isNull widgetDescription)) + map (.id) results `shouldBe` [widget.id] + + it "findMany in_ matches any listed value" $ \TestEnv {envPool = pool} -> do + alpha <- WidgetFixtures.insertWidget pool "alpha" + _ <- WidgetFixtures.insertWidget pool "beta" + gamma <- WidgetFixtures.insertWidget pool "gamma" + results <- runDb pool (Ops.findMany @WidgetTable @WidgetRow $ matching (in_ widgetName ["alpha", "gamma"])) + sort (map (.id) results) `shouldBe` sort [alpha.id, gamma.id] + + it "findMany in_ [] matches nothing" $ \TestEnv {envPool = pool} -> do + _ <- WidgetFixtures.insertWidget pool "alpha" + results <- runDb pool (Ops.findMany @WidgetTable @WidgetRow $ matching (in_ widgetName [])) + results `shouldBe` [] + + it "findMany or_ combines predicates" $ \TestEnv {envPool = pool} -> do + _ <- WidgetFixtures.insertWidget pool "alpha" + _ <- WidgetFixtures.insertWidget pool "beta" + _ <- WidgetFixtures.insertWidget pool "gamma" + results <- + runDb + pool + ( Ops.findMany @WidgetTable @WidgetRow $ + matching (eq widgetName "alpha" `or_` eq widgetName "gamma") + ) + sort (map (.name) results) `shouldBe` ["alpha", "gamma"] + + it "updateBuilder without WHERE returns EmptyWhere" $ \TestEnv {envPool = pool} -> do + result <- + runDb + pool + ( Update.updateBuilder @WidgetTable @WidgetRow $ + Update.setField widgetName "x" (Update.emptyUpdate @WidgetTable) + ) + result + `shouldSatisfy` ( \case + Left (EmptyWhere _) -> True + _ -> False + ) + + it "insert maps not-null violations" $ \TestEnv {envPool = pool} -> do + result <- + runDb + pool + ( Insert.insertBuilder @WidgetTable @WidgetRow $ + Insert.set widgetId nil (Insert.emptyInsert @WidgetTable) + ) + result + `shouldSatisfy` ( \case + Left (NotNullViolation _) -> True + _ -> False + ) + + it "insert maps foreign key violations" $ \TestEnv {envPool = pool} -> do + result <- + runDb + pool + ( Insert.insert @BookTable @BookRow + BookCreate + { id = Nothing, + shelfId = nil, + title = "ghost" + } + ) + result + `shouldSatisfy` ( \case + Left (ForeignKeyViolation _) -> True + _ -> False + ) + +insertDescribed pool name description = + runDb + pool + ( Insert.insert @WidgetTable @WidgetRow + WidgetCreate + { id = Nothing, + createdAt = Nothing, + updatedAt = Nothing, + name, + description = Value description + } + ) + >>= assertRight diff --git a/test/Poppy/RawSpec.hs b/test/Poppy/RawSpec.hs new file mode 100644 --- /dev/null +++ b/test/Poppy/RawSpec.hs @@ -0,0 +1,140 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module Poppy.RawSpec + ( rawSpec, + ) +where + +import Control.Exception (ErrorCall (..), throwIO, try) +import Data.Int (Int64) +import Data.Text (Text) +import Database.PostgreSQL.Simple.FromRow (FromRow (..), field) +import Database.PostgreSQL.Simple.Types (Query (..)) +import Poppy (NullableValue (Omit), ORMError (..), runDb, transaction, withTransaction) +import Poppy.Internal.Db (liftIO) +import qualified Poppy.Internal.Insert as Insert +import qualified Poppy.Internal.Operations as Ops +import Poppy.Internal.Sql (catchDb, executeRaw, param, queryRaw) +import qualified Poppy.WidgetFixtures as WidgetFixtures +import Schema.Widget (WidgetCreate (..), WidgetRow (..), WidgetTable) +import Support.TestDb (TestEnv (..)) +import Test.Hspec (SpecWith, describe, it, shouldBe, shouldSatisfy) + +data CountRow = CountRow {cnt :: Int64} + deriving (Eq, Show) + +instance FromRow CountRow where + fromRow = CountRow <$> field + +rawSpec :: SpecWith TestEnv +rawSpec = + describe "Poppy.Internal.Sql raw queries" $ do + it "queryRaw returns typed rows" $ \TestEnv {envPool = pool} -> do + _ <- WidgetFixtures.insertWidget pool "alpha" + _ <- WidgetFixtures.insertWidget pool "beta" + rows <- + runDb pool $ + queryRaw + (Query "SELECT COUNT(*) AS cnt FROM test_widget") + [] + rows `shouldBe` [CountRow 2] + + it "queryRaw binds parameters" $ \TestEnv {envPool = pool} -> do + widget <- WidgetFixtures.insertWidget pool "needle" + _ <- WidgetFixtures.insertWidget pool "hay" + rows <- + runDb pool $ + queryRaw + (Query "SELECT id, created_at, updated_at, name, description FROM test_widget WHERE name = ?") + [param ("needle" :: Text)] + rows `shouldBe` [widget] + + it "executeRaw updates rows" $ \TestEnv {envPool = pool} -> do + widget <- WidgetFixtures.insertWidget pool "before" + affected <- + runDb pool $ + executeRaw + (Query "UPDATE test_widget SET name = ? WHERE id = ?") + [param ("after" :: Text), param widget.id] + affected `shouldBe` 1 + updated <- runDb pool (Ops.findUnique @WidgetTable @WidgetRow widget.id) + fmap (.name) updated `shouldBe` Just "after" + + it "executeRaw changes are visible to subsequent reads within a transaction" $ \TestEnv {envPool = pool} -> do + widget <- WidgetFixtures.insertWidget pool "tx-before" + updated <- + withTransaction pool $ do + _ <- + executeRaw + (Query "UPDATE test_widget SET name = ? WHERE id = ?") + [param ("tx-after" :: Text), param widget.id] + Ops.findUnique @WidgetTable @WidgetRow widget.id + fmap (.name) updated `shouldBe` Just "tx-after" + persisted <- runDb pool (Ops.findUnique @WidgetTable @WidgetRow widget.id) + fmap (.name) persisted `shouldBe` Just "tx-after" + + it "queryRaw participates in withTransaction" $ \TestEnv {envPool = pool} -> do + widget <- WidgetFixtures.insertWidget pool "shared-connection" + (count, found) <- + withTransaction pool $ do + results <- + queryRaw + (Query "SELECT COUNT(*) AS cnt FROM test_widget WHERE id = ?") + [param widget.id] + row <- Ops.findUnique @WidgetTable @WidgetRow widget.id + pure (results, row) + count `shouldBe` [CountRow 1] + found `shouldBe` Just widget + + it "catchDb maps SQL errors to ORMError" $ \TestEnv {envPool = pool} -> do + result <- + runDb pool $ + catchDb $ + queryRaw @WidgetRow + (Query "SELECT * FROM definitely_not_a_real_table") + [] + result + `shouldSatisfy` ( \case + Left (DatabaseError _) -> True + _ -> False + ) + + it "transaction commits on success" $ \TestEnv {envPool = pool} -> do + inserted <- + runDb pool $ + transaction $ + Insert.insert @WidgetTable @WidgetRow + WidgetCreate + { id = Nothing, + createdAt = Nothing, + updatedAt = Nothing, + name = "tx-commit", + description = Omit + } + inserted + `shouldSatisfy` ( \case + Right row -> row.name == "tx-commit" + Left _ -> False + ) + rows <- runDb pool (Ops.findMany @WidgetTable @WidgetRow id) + length rows `shouldBe` 1 + + it "transaction rolls back when the action throws" $ \TestEnv {envPool = pool} -> do + _ <- + try @ErrorCall $ + runDb pool $ + transaction $ do + _ <- + Insert.insert @WidgetTable @WidgetRow + WidgetCreate + { id = Nothing, + createdAt = Nothing, + updatedAt = Nothing, + name = "tx-rollback", + description = Omit + } + liftIO $ throwIO (ErrorCall "boom") + rows <- runDb pool (Ops.findMany @WidgetTable @WidgetRow id) + rows `shouldBe` [] diff --git a/test/Poppy/ScalarSpec.hs b/test/Poppy/ScalarSpec.hs new file mode 100644 --- /dev/null +++ b/test/Poppy/ScalarSpec.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module Poppy.ScalarSpec + ( scalarSpec, + ) +where + +import Data.Aeson (object, (.=)) +import Data.Scientific (scientific) +import Data.Text (Text) +import Poppy (runDb) +import qualified Poppy.Internal.Insert as Insert +import qualified Poppy.Internal.Operations as Ops +import Schema.Packet +import Support.Assert (assertRight) +import Support.TestDb (TestEnv (..)) +import Test.Hspec (SpecWith, describe, it, shouldBe) + +scalarSpec :: SpecWith TestEnv +scalarSpec = + describe "numeric and jsonb scalars" $ do + it "round-trips Scientific and aeson Value through insert and select" $ \TestEnv {envPool = pool} -> do + let amount = scientific 1999 (-2) + payload = object ["kind" .= ("box" :: Text), "n" .= (2 :: Int)] + inserted <- + runDb + pool + ( Insert.insert @PacketTable @PacketRow + PacketCreate + { id = Nothing, + amount, + payload + } + ) + >>= assertRight + inserted.amount `shouldBe` amount + inserted.payload `shouldBe` payload + found <- runDb pool (Ops.findUnique @PacketTable @PacketRow inserted.id) + found `shouldBe` Just inserted diff --git a/test/Poppy/SelectSpec.hs b/test/Poppy/SelectSpec.hs new file mode 100644 --- /dev/null +++ b/test/Poppy/SelectSpec.hs @@ -0,0 +1,252 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedRecordDot #-} + +module Poppy.SelectSpec + ( selectSpec, + ) +where + +import Poppy (ORMError (..), Picked (..), asc, desc, loadWith, runDb, skip) +import qualified Poppy.Internal.Operations as Ops +import Poppy.Internal.Query (selectColumns) +import Poppy.Internal.Select (picked) +import qualified Poppy.ShelfFixtures as ShelfFixtures +import Poppy.Internal.Where (eq) +import qualified Poppy.WidgetFixtures as WidgetFixtures +import Schema.Book (BookRow (..)) +import qualified Schema.Client.Shelf as Shelf +import qualified Schema.Client.Widget as Widget +import Schema.Include.Book (BookInclude (..), BookWith (..)) +import Schema.Include.Shelf (ShelfInclude (..), ShelfWith (..), ShelfWithPicked (..)) +import Schema.Shelf (ShelfPicked (..), ShelfRow (..), shelfId, shelfName) +import Schema.Widget + ( WidgetPicked (..), + WidgetRow (..), + WidgetSelect (..), + WidgetTable, + parseWidgetPicked, + widgetCreatedAt, + widgetName, + widgetSelectColumns, + ) +import Support.Assert (assertRight) +import Support.TestDb (TestEnv (..)) +import Test.Hspec (SpecWith, describe, it, shouldBe, shouldSatisfy) + +selectSpec :: SpecWith TestEnv +selectSpec = do + describe "Poppy.Internal.Select columns" $ do + it "always includes the primary key and only requested scalars" $ \_ -> + widgetSelectColumns + WidgetSelect + { id = False, + createdAt = False, + updatedAt = False, + name = True, + description = True + } + `shouldBe` ["id", "name", "description"] + + it "maps False fields to Skipped" $ \_ -> do + picked False ("secret" :: String) `shouldBe` Skipped + picked True ("shown" :: String) `shouldBe` Picked "shown" + + describe "single-table select_" $ do + it "loads only requested widget columns into WidgetPicked" $ \TestEnv {envPool = pool} -> do + widget <- WidgetFixtures.insertWidget pool "alpha" + let sel = + WidgetSelect + { id = False, + createdAt = False, + updatedAt = False, + name = True, + description = False + } + [row] <- + runDb pool $ + Ops.findManyWith @WidgetTable + (parseWidgetPicked sel) + (selectColumns (widgetSelectColumns sel)) + let WidgetRow {id = widgetId} = widget + WidgetPicked {id = rowId, name = rowName, description = rowDescription, createdAt = rowCreatedAt, updatedAt = rowUpdatedAt} = row + rowId `shouldBe` widgetId + rowName `shouldBe` Picked "alpha" + rowDescription `shouldBe` Skipped + rowCreatedAt `shouldBe` Skipped + rowUpdatedAt `shouldBe` Skipped + + it "keeps WidgetRow when select_ is OmitSelect" $ \TestEnv {envPool = pool} -> do + created <- WidgetFixtures.insertWidget pool "salt" + rows <- runDb pool (Widget.findMany Widget.emptyQuery) + map (.name) rows `shouldBe` ["salt"] + map (.id) rows `shouldBe` [created.id] + + it "findUnique looks up by primary key" $ \TestEnv {envPool = pool} -> do + created <- WidgetFixtures.insertWidget pool "thyme" + found <- + runDb + pool + (Widget.findUnique (Widget.uniqueQuery (Widget.ById created.id))) + found `shouldBe` Right (Just created) + + it "findUnique looks up by a declared unique" $ \TestEnv {envPool = pool} -> do + created <- WidgetFixtures.insertWidget pool "sage" + found <- + runDb + pool + (Widget.findUnique (Widget.uniqueQuery (Widget.ByName "sage"))) + found `shouldBe` Right (Just created) + + it "findUnique projects columns when select_ is set" $ \TestEnv {envPool = pool} -> do + created <- WidgetFixtures.insertWidget pool "basil" + let sel = + WidgetSelect + { id = False, + createdAt = False, + updatedAt = False, + name = True, + description = False + } + found <- + runDb + pool + (Widget.findUnique ((Widget.uniqueQuery (Widget.ById created.id)) {Widget.select_ = sel})) + >>= assertRight + fmap (.name) found `shouldBe` Just (Picked "basil") + + it "returns WidgetPicked when select_ is set" $ \TestEnv {envPool = pool} -> do + created <- WidgetFixtures.insertWidget pool "pepper" + let sel = + WidgetSelect + { id = False, + createdAt = False, + updatedAt = False, + name = True, + description = False + } + query :: Widget.WidgetQuery WidgetSelect + query = + Widget.WidgetQuery + { select_ = sel, + where_ = Nothing, + orderBy_ = [], + limit_ = Nothing, + offset_ = Nothing + } + [row] <- runDb pool (Widget.findMany query) + row.id `shouldBe` created.id + row.name `shouldBe` Picked "pepper" + row.createdAt `shouldBe` Skipped + row.updatedAt `shouldBe` Skipped + + it "findMany orderBy_ sorts by listed fields" $ \TestEnv {envPool = pool} -> do + _ <- WidgetFixtures.insertWidget pool "beta" + _ <- WidgetFixtures.insertWidget pool "alpha" + _ <- WidgetFixtures.insertWidget pool "gamma" + ascending <- + runDb + pool + (Widget.findMany Widget.emptyQuery {Widget.orderBy_ = [asc widgetName]}) + descending <- + runDb + pool + (Widget.findMany Widget.emptyQuery {Widget.orderBy_ = [desc widgetName]}) + multi <- + runDb + pool + ( Widget.findMany + Widget.emptyQuery {Widget.orderBy_ = [asc widgetName, desc widgetCreatedAt]} + ) + map (.name) ascending `shouldBe` ["alpha", "beta", "gamma"] + map (.name) descending `shouldBe` ["gamma", "beta", "alpha"] + map (.name) multi `shouldBe` ["alpha", "beta", "gamma"] + + it "count and findFirst use the generated Client" $ \TestEnv {envPool = pool} -> do + _ <- WidgetFixtures.insertWidget pool "beta" + alpha <- WidgetFixtures.insertWidget pool "alpha" + n <- runDb pool (Widget.count Widget.emptyQuery {Widget.where_ = Just (eq widgetName "alpha")}) + n `shouldBe` 1 + firstAsc <- + runDb + pool + ( Widget.findFirst + Widget.emptyQuery {Widget.orderBy_ = [asc widgetName]} + ) + firstAsc `shouldBe` Just alpha + missing <- + runDb + pool + ( Widget.findFirstOrFail + Widget.emptyQuery {Widget.where_ = Just (eq widgetName "missing")} + ) + missing + `shouldSatisfy` ( \case + Left (RecordNotFound _) -> True + _ -> False + ) + + describe "select_ + include" $ do + it "projects shelf scalars and keeps nested books" $ \TestEnv {envPool = pool} -> do + shelf <- ShelfFixtures.insertShelf pool "fiction" + _ <- ShelfFixtures.insertBook pool shelf.id "Dune" + let sel = + Shelf.ShelfSelect + { id = False, + name = True + } + query = + Shelf.ShelfQuery + { include_ = shelfInclude, + select_ = sel, + where_ = Just (eq shelfName "fiction"), + orderBy_ = [], + limit_ = Nothing, + offset_ = Nothing + } + [row] <- runDb pool (Shelf.findMany query) + row.shelf.id `shouldBe` shelf.id + row.shelf.name `shouldBe` Picked "fiction" + length row.books `shouldBe` 1 + (head row.books).book.title `shouldBe` "Dune" + + it "findMany emptyQuery returns ShelfRow without include_" $ \TestEnv {envPool = pool} -> do + created <- ShelfFixtures.insertShelf pool "Toast" + rows <- runDb pool (Shelf.findMany Shelf.emptyQuery) + map (.name) rows `shouldBe` ["Toast"] + map (.id) rows `shouldBe` [created.id] + found <- + runDb + pool + (Shelf.findUnique (Shelf.uniqueQuery (Shelf.ById created.id))) + >>= assertRight + fmap (.name) found `shouldBe` Just "Toast" + + it "findUnique loads included relations" $ \TestEnv {envPool = pool} -> do + shelf <- ShelfFixtures.insertShelf pool "Omelette" + _ <- ShelfFixtures.insertBook pool shelf.id "Eggs" + found <- + runDb + pool + (Shelf.findUnique ((Shelf.uniqueQuery (Shelf.ById shelf.id)) {Shelf.include_ = shelfInclude})) + >>= assertRight + fmap (.shelf.name) found `shouldBe` Just "Omelette" + fmap (length . (.books)) found `shouldBe` Just 1 + + it "create and findMany share Schema.Client.Shelf" $ \TestEnv {envPool = pool} -> do + created <- + runDb pool (Shelf.create (Shelf.ShelfCreate {id = Nothing, name = "Pantry", books = [], tags = []})) + >>= assertRight + rows <- + runDb + pool + ( Shelf.findMany + Shelf.emptyQuery + { Shelf.include_ = shelfInclude, + Shelf.where_ = Just (eq shelfId created.id) + } + ) + map ((.name) . (.shelf)) rows `shouldBe` ["Pantry"] + map ((.id) . (.shelf)) rows `shouldBe` [created.id] + +shelfInclude = + ShelfInclude {books = loadWith (BookInclude {chapters = skip}), tags = skip} diff --git a/test/Poppy/ShelfFixtures.hs b/test/Poppy/ShelfFixtures.hs new file mode 100644 --- /dev/null +++ b/test/Poppy/ShelfFixtures.hs @@ -0,0 +1,45 @@ +module Poppy.ShelfFixtures + ( insertShelf, + insertBook, + insertChapter, + insertSection, + insertTag, + ) +where + +import Data.Text (Text) +import Data.UUID (UUID) +import Poppy (runDb) +import Poppy.Internal.Db (DbPool) +import qualified Poppy.Internal.Insert as Insert +import Schema.Book (BookCreate (..), BookRow (..), BookTable) +import Schema.Chapter (ChapterCreate (..), ChapterRow (..), ChapterTable) +import Schema.Section (SectionCreate (..), SectionRow (..), SectionTable) +import Schema.Shelf (ShelfCreate (..), ShelfRow (..), ShelfTable) +import Schema.Tag (TagCreate (..), TagRow (..), TagTable) +import Support.Assert (assertRight) + +insertShelf :: DbPool -> Text -> IO ShelfRow +insertShelf pool name = + runDb pool (Insert.insert @ShelfTable @ShelfRow (ShelfCreate {id = Nothing, name})) + >>= assertRight + +insertBook :: DbPool -> UUID -> Text -> IO BookRow +insertBook pool shelfId title = + runDb pool (Insert.insert @BookTable @BookRow (BookCreate {id = Nothing, shelfId, title})) + >>= assertRight + +insertChapter :: DbPool -> UUID -> Text -> IO ChapterRow +insertChapter pool bookRef heading = + runDb pool (Insert.insert @ChapterTable @ChapterRow (ChapterCreate {id = Nothing, bookRef, heading})) + >>= assertRight + +insertSection :: DbPool -> UUID -> Text -> IO SectionRow +insertSection pool chapterRef label = + runDb pool (Insert.insert @SectionTable @SectionRow (SectionCreate {id = Nothing, chapterRef, label})) + >>= assertRight + +insertTag :: DbPool -> UUID -> Text -> IO TagRow +insertTag pool shelfId label = + runDb pool (Insert.insert @TagTable @TagRow (TagCreate {id = Nothing, shelfId, label})) + >>= assertRight diff --git a/test/Poppy/UniqueFailSpec.hs b/test/Poppy/UniqueFailSpec.hs new file mode 100644 --- /dev/null +++ b/test/Poppy/UniqueFailSpec.hs @@ -0,0 +1,42 @@ +module Poppy.UniqueFailSpec + ( uniqueFailSpec, + ) +where + +import System.Exit (ExitCode (..)) +import System.Process (readProcessWithExitCode) +import Test.Hspec + +uniqueFailSpec :: Spec +uniqueFailSpec = + describe "unique key type errors" $ + it "rejects a where_ passed to findUnique" $ do + err <- expectFail "unique-fail/NonUniqueFilter.hs" + err `shouldContain` "WidgetUniqueQuery" + +expectFail :: FilePath -> IO String +expectFail path = do + (code, _, err) <- + readProcessWithExitCode + "cabal" + ( ["exec", "--", "ghc", "-package", "poppy", "-fno-code", "-w", "-itest", "-outputdir", "/tmp/poppy-unique-fail"] + ++ extensions + ++ [path] + ) + "" + case code of + ExitSuccess -> expectationFailure ("expected " <> path <> " to fail") >> pure err + _ -> pure err + +extensions :: [String] +extensions = + [ "-XAllowAmbiguousTypes", + "-XDuplicateRecordFields", + "-XLambdaCase", + "-XNamedFieldPuns", + "-XOverloadedRecordDot", + "-XOverloadedStrings", + "-XScopedTypeVariables", + "-XTypeApplications", + "-XTypeFamilies" + ] diff --git a/test/Poppy/WhereSpec.hs b/test/Poppy/WhereSpec.hs new file mode 100644 --- /dev/null +++ b/test/Poppy/WhereSpec.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Poppy.WhereSpec + ( whereSpec, + ) +where + +import Data.Text (Text) +import Poppy.Internal.Core (Field (..)) +import Poppy.Internal.Where + ( Where, + and_, + compileWhere, + contains, + eq, + gt, + in_, + isNull, + not_, + or_, + ) +import Test.Hspec + +data UserTable + +userName :: Field UserTable Text +userName = Field "name" "name" + +userAge :: Field UserTable Int +userAge = Field "age" "age" + +whereSql :: Where UserTable -> Text +whereSql = fst . compileWhere + +whereSpec :: Spec +whereSpec = + describe "Poppy.Internal.Where" $ do + it "compiles eq" $ + whereSql (eq userName "Ada") `shouldBe` "\"name\" = ?" + + it "compiles gt" $ + whereSql (gt userAge 30) `shouldBe` "\"age\" > ?" + + it "compiles isNull" $ + whereSql (isNull userName) `shouldBe` "\"name\" IS NULL" + + it "compiles empty in_ as FALSE" $ + whereSql (in_ userAge []) `shouldBe` "FALSE" + + it "compiles in_" $ + whereSql (in_ userAge [1, 2]) `shouldBe` "\"age\" IN ?" + + it "compiles contains as case-insensitive substring" $ + whereSql (contains userName "salt") + `shouldBe` "POSITION(LOWER(?) IN LOWER(\"name\")) > 0" + + it "compiles and_ / or_ / not_ with parentheses" $ + whereSql (eq userName "Ada" `and_` not_ (isNull userAge) `or_` gt userAge 40) + `shouldBe` "((\"name\" = ?) AND (NOT (\"age\" IS NULL))) OR (\"age\" > ?)" diff --git a/test/Poppy/WidgetFixtures.hs b/test/Poppy/WidgetFixtures.hs new file mode 100644 --- /dev/null +++ b/test/Poppy/WidgetFixtures.hs @@ -0,0 +1,26 @@ +module Poppy.WidgetFixtures + ( insertWidget, + ) +where + +import Data.Text (Text) +import Poppy (NullableValue (Omit), runDb) +import Poppy.Internal.Db (DbPool) +import qualified Poppy.Internal.Insert as Insert +import Schema.Widget +import Support.Assert (assertRight) + +insertWidget :: DbPool -> Text -> IO WidgetRow +insertWidget pool name = + runDb + pool + ( Insert.insert @WidgetTable @WidgetRow + WidgetCreate + { id = Nothing, + createdAt = Nothing, + updatedAt = Nothing, + name, + description = Omit + } + ) + >>= assertRight diff --git a/test/Schema/Article.hs b/test/Schema/Article.hs new file mode 100644 --- /dev/null +++ b/test/Schema/Article.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NoFieldSelectors #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE TypeApplications #-} + +module Schema.Article + ( ArticleTable (..), + ArticleRow (..), + ArticleSelect (..), + ArticlePicked (..), + articleSelect, + articleSelectColumns, + parseArticlePicked, + toArticlePicked, + ArticleCreate (..), + ArticleUpdate (..), + articleId, + articleAuthorId, + articleTitle + ) +where + +import Data.Text (Text) +import Data.UUID (UUID) +import Poppy.Internal.Generated + ( FromRow (..), + RowParser, + field, + Entity (..), + Field (..), + PrimaryKeyType, + ModelTable, + Picked (..), + picked, + Insertable (..), + emptyInsert, + set, + setMaybe, + Updatable (..), + emptyUpdate, + setFieldMaybe + ) + +data ArticleTable = ArticleTable + +type instance PrimaryKeyType ArticleTable = UUID + +type instance ModelTable "Article" = ArticleTable + +instance Entity ArticleTable where + tableName = "test_article" + primaryKey = articleId + tableColumns = ["id", "author_id", "title"] + +instance Insertable ArticleTable where + type CreateInput ArticleTable = ArticleCreate + toInsertBuilder input = + setMaybe articleId input.id $ + set articleAuthorId input.authorId $ + set articleTitle input.title $ + emptyInsert @ArticleTable + + +instance Updatable ArticleTable where + type UpdateInput ArticleTable = ArticleUpdate + updatedAtField = Nothing + toUpdateBuilder input = + setFieldMaybe articleAuthorId input.authorId $ + setFieldMaybe articleTitle input.title $ + emptyUpdate @ArticleTable + + +data ArticleRow = ArticleRow + { id :: UUID, + authorId :: UUID, + title :: Text + } + deriving (Show, Eq) + + +data ArticleCreate = ArticleCreate + { id :: Maybe UUID, + authorId :: UUID, + title :: Text + } + deriving (Show, Eq) + + +data ArticleUpdate = ArticleUpdate + { authorId :: Maybe UUID, + title :: Maybe Text + } + deriving (Show, Eq) + + +instance FromRow ArticleRow where + fromRow = ArticleRow <$> field <*> field <*> field + + +data ArticleSelect = ArticleSelect + { id :: Bool, + authorId :: Bool, + title :: Bool + } + deriving (Show, Eq) +data ArticlePicked = ArticlePicked + { id :: UUID, + authorId :: Picked UUID, + title :: Picked Text + } + deriving (Show, Eq) +articleSelect :: ArticleSelect +articleSelect = + ArticleSelect + { id = False, + authorId = False, + title = False + } +articleSelectColumns :: ArticleSelect -> [Text] +articleSelectColumns select_ = + fieldColumn articleId + : concat + [ [fieldColumn articleAuthorId | select_.authorId] + , [fieldColumn articleTitle | select_.title] + ] +parseArticlePicked :: ArticleSelect -> RowParser ArticlePicked +parseArticlePicked select_ = do + idVal <- field + authorIdVal <- if select_.authorId then Picked <$> field else pure Skipped + titleVal <- if select_.title then Picked <$> field else pure Skipped + pure ArticlePicked { id = idVal, authorId = authorIdVal, title = titleVal } +toArticlePicked :: ArticleSelect -> ArticleRow -> ArticlePicked +toArticlePicked select_ row = + ArticlePicked + { id = row.id, + authorId = picked select_.authorId row.authorId, + title = picked select_.title row.title + } + + +articleId :: Field ArticleTable UUID +articleId = Field "id" "id" + +articleAuthorId :: Field ArticleTable UUID +articleAuthorId = Field "authorId" "author_id" + +articleTitle :: Field ArticleTable Text +articleTitle = Field "title" "title" + diff --git a/test/Schema/Author.hs b/test/Schema/Author.hs new file mode 100644 --- /dev/null +++ b/test/Schema/Author.hs @@ -0,0 +1,136 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NoFieldSelectors #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE TypeApplications #-} + +module Schema.Author + ( AuthorTable (..), + AuthorRow (..), + AuthorSelect (..), + AuthorPicked (..), + authorSelect, + authorSelectColumns, + parseAuthorPicked, + toAuthorPicked, + AuthorCreate (..), + AuthorUpdate (..), + authorId, + authorName + ) +where + +import Data.Text (Text) +import Data.UUID (UUID) +import Poppy.Internal.Generated + ( FromRow (..), + RowParser, + field, + Entity (..), + Field (..), + PrimaryKeyType, + ModelTable, + Picked (..), + picked, + Insertable (..), + emptyInsert, + set, + setMaybe, + Updatable (..), + emptyUpdate, + setFieldMaybe + ) + +data AuthorTable = AuthorTable + +type instance PrimaryKeyType AuthorTable = UUID + +type instance ModelTable "Author" = AuthorTable + +instance Entity AuthorTable where + tableName = "test_author" + primaryKey = authorId + tableColumns = ["id", "name"] + +instance Insertable AuthorTable where + type CreateInput AuthorTable = AuthorCreate + toInsertBuilder input = + setMaybe authorId input.id $ + set authorName input.name $ + emptyInsert @AuthorTable + + +instance Updatable AuthorTable where + type UpdateInput AuthorTable = AuthorUpdate + updatedAtField = Nothing + toUpdateBuilder input = + setFieldMaybe authorName input.name $ + emptyUpdate @AuthorTable + + +data AuthorRow = AuthorRow + { id :: UUID, + name :: Text + } + deriving (Show, Eq) + + +data AuthorCreate = AuthorCreate + { id :: Maybe UUID, + name :: Text + } + deriving (Show, Eq) + + +data AuthorUpdate = AuthorUpdate + { name :: Maybe Text + } + deriving (Show, Eq) + + +instance FromRow AuthorRow where + fromRow = AuthorRow <$> field <*> field + + +data AuthorSelect = AuthorSelect + { id :: Bool, + name :: Bool + } + deriving (Show, Eq) +data AuthorPicked = AuthorPicked + { id :: UUID, + name :: Picked Text + } + deriving (Show, Eq) +authorSelect :: AuthorSelect +authorSelect = + AuthorSelect + { id = False, + name = False + } +authorSelectColumns :: AuthorSelect -> [Text] +authorSelectColumns select_ = + fieldColumn authorId + : concat + [ [fieldColumn authorName | select_.name] + ] +parseAuthorPicked :: AuthorSelect -> RowParser AuthorPicked +parseAuthorPicked select_ = do + idVal <- field + nameVal <- if select_.name then Picked <$> field else pure Skipped + pure AuthorPicked { id = idVal, name = nameVal } +toAuthorPicked :: AuthorSelect -> AuthorRow -> AuthorPicked +toAuthorPicked select_ row = + AuthorPicked + { id = row.id, + name = picked select_.name row.name + } + + +authorId :: Field AuthorTable UUID +authorId = Field "id" "id" + +authorName :: Field AuthorTable Text +authorName = Field "name" "name" + diff --git a/test/Schema/Book.hs b/test/Schema/Book.hs new file mode 100644 --- /dev/null +++ b/test/Schema/Book.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NoFieldSelectors #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE TypeApplications #-} + +module Schema.Book + ( BookTable (..), + BookRow (..), + BookSelect (..), + BookPicked (..), + bookSelect, + bookSelectColumns, + parseBookPicked, + toBookPicked, + BookCreate (..), + BookUpdate (..), + bookId, + bookShelfId, + bookTitle + ) +where + +import Data.Text (Text) +import Data.UUID (UUID) +import Poppy.Internal.Generated + ( FromRow (..), + RowParser, + field, + Entity (..), + Field (..), + PrimaryKeyType, + ModelTable, + Picked (..), + picked, + Insertable (..), + emptyInsert, + set, + setMaybe, + Updatable (..), + emptyUpdate, + setFieldMaybe + ) + +data BookTable = BookTable + +type instance PrimaryKeyType BookTable = UUID + +type instance ModelTable "Book" = BookTable + +instance Entity BookTable where + tableName = "test_book" + primaryKey = bookId + tableColumns = ["id", "shelf_id", "title"] + +instance Insertable BookTable where + type CreateInput BookTable = BookCreate + toInsertBuilder input = + setMaybe bookId input.id $ + set bookShelfId input.shelfId $ + set bookTitle input.title $ + emptyInsert @BookTable + + +instance Updatable BookTable where + type UpdateInput BookTable = BookUpdate + updatedAtField = Nothing + toUpdateBuilder input = + setFieldMaybe bookShelfId input.shelfId $ + setFieldMaybe bookTitle input.title $ + emptyUpdate @BookTable + + +data BookRow = BookRow + { id :: UUID, + shelfId :: UUID, + title :: Text + } + deriving (Show, Eq) + + +data BookCreate = BookCreate + { id :: Maybe UUID, + shelfId :: UUID, + title :: Text + } + deriving (Show, Eq) + + +data BookUpdate = BookUpdate + { shelfId :: Maybe UUID, + title :: Maybe Text + } + deriving (Show, Eq) + + +instance FromRow BookRow where + fromRow = BookRow <$> field <*> field <*> field + + +data BookSelect = BookSelect + { id :: Bool, + shelfId :: Bool, + title :: Bool + } + deriving (Show, Eq) +data BookPicked = BookPicked + { id :: UUID, + shelfId :: Picked UUID, + title :: Picked Text + } + deriving (Show, Eq) +bookSelect :: BookSelect +bookSelect = + BookSelect + { id = False, + shelfId = False, + title = False + } +bookSelectColumns :: BookSelect -> [Text] +bookSelectColumns select_ = + fieldColumn bookId + : concat + [ [fieldColumn bookShelfId | select_.shelfId] + , [fieldColumn bookTitle | select_.title] + ] +parseBookPicked :: BookSelect -> RowParser BookPicked +parseBookPicked select_ = do + idVal <- field + shelfIdVal <- if select_.shelfId then Picked <$> field else pure Skipped + titleVal <- if select_.title then Picked <$> field else pure Skipped + pure BookPicked { id = idVal, shelfId = shelfIdVal, title = titleVal } +toBookPicked :: BookSelect -> BookRow -> BookPicked +toBookPicked select_ row = + BookPicked + { id = row.id, + shelfId = picked select_.shelfId row.shelfId, + title = picked select_.title row.title + } + + +bookId :: Field BookTable UUID +bookId = Field "id" "id" + +bookShelfId :: Field BookTable UUID +bookShelfId = Field "shelfId" "shelf_id" + +bookTitle :: Field BookTable Text +bookTitle = Field "title" "title" + diff --git a/test/Schema/Chapter.hs b/test/Schema/Chapter.hs new file mode 100644 --- /dev/null +++ b/test/Schema/Chapter.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NoFieldSelectors #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE TypeApplications #-} + +module Schema.Chapter + ( ChapterTable (..), + ChapterRow (..), + ChapterSelect (..), + ChapterPicked (..), + chapterSelect, + chapterSelectColumns, + parseChapterPicked, + toChapterPicked, + ChapterCreate (..), + ChapterUpdate (..), + chapterId, + chapterBookRef, + chapterHeading + ) +where + +import Data.Text (Text) +import Data.UUID (UUID) +import Poppy.Internal.Generated + ( FromRow (..), + RowParser, + field, + Entity (..), + Field (..), + PrimaryKeyType, + ModelTable, + Picked (..), + picked, + Insertable (..), + emptyInsert, + set, + setMaybe, + Updatable (..), + emptyUpdate, + setFieldMaybe + ) + +data ChapterTable = ChapterTable + +type instance PrimaryKeyType ChapterTable = UUID + +type instance ModelTable "Chapter" = ChapterTable + +instance Entity ChapterTable where + tableName = "test_chapter" + primaryKey = chapterId + tableColumns = ["id", "book_id", "heading"] + +instance Insertable ChapterTable where + type CreateInput ChapterTable = ChapterCreate + toInsertBuilder input = + setMaybe chapterId input.id $ + set chapterBookRef input.bookRef $ + set chapterHeading input.heading $ + emptyInsert @ChapterTable + + +instance Updatable ChapterTable where + type UpdateInput ChapterTable = ChapterUpdate + updatedAtField = Nothing + toUpdateBuilder input = + setFieldMaybe chapterBookRef input.bookRef $ + setFieldMaybe chapterHeading input.heading $ + emptyUpdate @ChapterTable + + +data ChapterRow = ChapterRow + { id :: UUID, + bookRef :: UUID, + heading :: Text + } + deriving (Show, Eq) + + +data ChapterCreate = ChapterCreate + { id :: Maybe UUID, + bookRef :: UUID, + heading :: Text + } + deriving (Show, Eq) + + +data ChapterUpdate = ChapterUpdate + { bookRef :: Maybe UUID, + heading :: Maybe Text + } + deriving (Show, Eq) + + +instance FromRow ChapterRow where + fromRow = ChapterRow <$> field <*> field <*> field + + +data ChapterSelect = ChapterSelect + { id :: Bool, + bookRef :: Bool, + heading :: Bool + } + deriving (Show, Eq) +data ChapterPicked = ChapterPicked + { id :: UUID, + bookRef :: Picked UUID, + heading :: Picked Text + } + deriving (Show, Eq) +chapterSelect :: ChapterSelect +chapterSelect = + ChapterSelect + { id = False, + bookRef = False, + heading = False + } +chapterSelectColumns :: ChapterSelect -> [Text] +chapterSelectColumns select_ = + fieldColumn chapterId + : concat + [ [fieldColumn chapterBookRef | select_.bookRef] + , [fieldColumn chapterHeading | select_.heading] + ] +parseChapterPicked :: ChapterSelect -> RowParser ChapterPicked +parseChapterPicked select_ = do + idVal <- field + bookRefVal <- if select_.bookRef then Picked <$> field else pure Skipped + headingVal <- if select_.heading then Picked <$> field else pure Skipped + pure ChapterPicked { id = idVal, bookRef = bookRefVal, heading = headingVal } +toChapterPicked :: ChapterSelect -> ChapterRow -> ChapterPicked +toChapterPicked select_ row = + ChapterPicked + { id = row.id, + bookRef = picked select_.bookRef row.bookRef, + heading = picked select_.heading row.heading + } + + +chapterId :: Field ChapterTable UUID +chapterId = Field "id" "id" + +chapterBookRef :: Field ChapterTable UUID +chapterBookRef = Field "bookRef" "book_id" + +chapterHeading :: Field ChapterTable Text +chapterHeading = Field "heading" "heading" + diff --git a/test/Schema/Client/Article.hs b/test/Schema/Client/Article.hs new file mode 100644 --- /dev/null +++ b/test/Schema/Client/Article.hs @@ -0,0 +1,213 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +module Schema.Client.Article + ( create, + createMany, + update, + updateMany, + upsert, + findMany, + findUnique, + findUniqueOrFail, + findFirst, + findFirstOrFail, + count, + delete, + deleteMany, + ArticleCreate (..), + ArticleRow (..), + ArticleSelect (..), + ArticlePicked (..), + articleSelect, + OmitSelect (..), + Picked (..), + ResolveSelect, + ArticleUpdate (..), + ArticleTable, + ArticleQuery (..), + ArticleUnique (..), + ArticleUniqueKey (..), + ArticleUniqueQuery (..), + emptyQuery, + uniqueQuery, + articleUniqueWhere, + articleId + ) + +where + +import Data.Text (Text) +import Data.UUID (UUID) +import Poppy.Internal.Generated + ( Db, + ORMError (..), + fromUniqueRows, + requireFound, + uniqueOrFail, + OrderBy, + QueryBuilder, + applyQueryModifiers, + matching, + selectColumns, + OmitSelect (..), + Picked (..), + Where, + eq + ) +import qualified Poppy.Internal.Generated as Delete + ( deleteMany + ) +import qualified Poppy.Internal.Generated as Insert + ( insert, + insertMany, + upsert + ) +import qualified Poppy.Internal.Generated as Ops + ( findMany, + findManyWith, + findFirst, + findFirstWith, + count + ) +import qualified Poppy.Internal.Generated as Update + ( updateWhere, + updateMany + ) + +import Schema.Article (ArticleCreate (..), ArticleRow (..), ArticleSelect (..), ArticlePicked (..), articleSelect, articleSelectColumns, parseArticlePicked, ArticleTable, ArticleUpdate (..), articleId) + +data ArticleUnique + = ById UUID + deriving (Eq, Show) + +data ArticleUniqueKey + = OnId + deriving (Eq, Show) + +articleUniqueWhere :: ArticleUnique -> Where ArticleTable +articleUniqueWhere = \case + ById v1 -> eq articleId v1 + +articleConflictCols :: ArticleUniqueKey -> [Text] +articleConflictCols = \case + OnId -> ["id"] + + +create :: ArticleCreate -> Db (Either ORMError ArticleRow) +create = Insert.insert @ArticleTable @ArticleRow + + +createMany :: [ArticleCreate] -> Db (Either ORMError Int) +createMany = Insert.insertMany @ArticleTable + + +update :: ArticleUnique -> ArticleUpdate -> Db (Either ORMError ArticleRow) +update key input = + Update.updateWhere @ArticleTable @ArticleRow (articleUniqueWhere key) input + + +updateMany :: Where ArticleTable -> ArticleUpdate -> Db (Either ORMError Int) +updateMany = Update.updateMany @ArticleTable + + +upsert :: ArticleUniqueKey -> ArticleCreate -> ArticleUpdate -> Db (Either ORMError ArticleRow) +upsert key createInput updateInput = + Insert.upsert @ArticleTable @ArticleRow (articleConflictCols key) createInput updateInput + + +data ArticleQuery select = ArticleQuery + { select_ :: select + , where_ :: Maybe (Where ArticleTable) + , orderBy_ :: [OrderBy ArticleTable] + , limit_ :: Maybe Int + , offset_ :: Maybe Int + } + + +data ArticleUniqueQuery select = ArticleUniqueQuery + { select_ :: select + , where_ :: ArticleUnique + } + + +emptyQuery :: ArticleQuery OmitSelect +emptyQuery = + ArticleQuery {select_ = OmitSelect, where_ = Nothing, orderBy_ = [], limit_ = Nothing, offset_ = Nothing} + + +uniqueQuery :: ArticleUnique -> ArticleUniqueQuery OmitSelect +uniqueQuery key = + ArticleUniqueQuery {select_ = OmitSelect, where_ = key} + + +type family ResolveSelect select +type instance ResolveSelect OmitSelect = ArticleRow +type instance ResolveSelect ArticleSelect = ArticlePicked + + +class ReadArticle select where + findMany :: ArticleQuery select -> Db [ResolveSelect select] + findUnique :: ArticleUniqueQuery select -> Db (Either ORMError (Maybe (ResolveSelect select))) + findUniqueOrFail :: ArticleUniqueQuery select -> Db (Either ORMError (ResolveSelect select)) + findFirst :: ArticleQuery select -> Db (Maybe (ResolveSelect select)) + findFirstOrFail :: ArticleQuery select -> Db (Either ORMError (ResolveSelect select)) + +instance ReadArticle OmitSelect where + findMany q = + Ops.findMany @ArticleTable @ArticleRow (applyQuery q) + findUnique ArticleUniqueQuery {where_} = do + let w = articleUniqueWhere where_ + rows <- Ops.findMany @ArticleTable @ArticleRow (matching w) + pure (fromUniqueRows rows) + findUniqueOrFail q = uniqueOrFail <$> findUnique q + findFirst q = + Ops.findFirst @ArticleTable @ArticleRow (applyQuery q) + findFirstOrFail q = do + result <- findFirst q + pure $ requireFound result (RecordNotFound "No record found matching query") + +instance ReadArticle ArticleSelect where + findMany q@ArticleQuery {select_} = + Ops.findManyWith + (parseArticlePicked select_) + (selectColumns (articleSelectColumns select_) . applyQuery q) + findUnique ArticleUniqueQuery {where_, select_} = do + let w = articleUniqueWhere where_ + rows <- + Ops.findManyWith + (parseArticlePicked select_) + (selectColumns (articleSelectColumns select_) . matching w) + pure (fromUniqueRows rows) + findUniqueOrFail q = uniqueOrFail <$> findUnique q + findFirst q@ArticleQuery {select_} = + Ops.findFirstWith + (parseArticlePicked select_) + (selectColumns (articleSelectColumns select_) . applyQuery q) + findFirstOrFail q = do + result <- findFirst q + pure $ requireFound result (RecordNotFound "No record found matching query") + +applyQuery :: ArticleQuery select -> QueryBuilder ArticleTable -> QueryBuilder ArticleTable +applyQuery ArticleQuery {where_, orderBy_, limit_, offset_} = + applyQueryModifiers where_ orderBy_ limit_ offset_ + + +count :: ArticleQuery select -> Db Int +count q = Ops.count @ArticleTable (applyQuery q) + + +delete :: ArticleUnique -> Db (Either ORMError Int) +delete key = + Delete.deleteMany @ArticleTable (articleUniqueWhere key) + + +deleteMany :: Where ArticleTable -> Db (Either ORMError Int) +deleteMany = Delete.deleteMany @ArticleTable + diff --git a/test/Schema/Client/Author.hs b/test/Schema/Client/Author.hs new file mode 100644 --- /dev/null +++ b/test/Schema/Client/Author.hs @@ -0,0 +1,486 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NoFieldSelectors #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +{- | Generated Client. Do not edit. + +Nested writes live on 'create' / 'update'. + create-time relation fields are [CreateChild | ConnectChild unique] + update-time relation fields are Maybe Update (replaceWith, create, connect, delete, update, upsert; + disconnect when the child foreign key is nullable) +-} +module Schema.Client.Author + ( findMany, + findUnique, + findUniqueOrFail, + findFirst, + findFirstOrFail, + count, + create, + createMany, + update, + updateMany, + upsert, + delete, + deleteMany, + AuthorCreateScalars, + AuthorUpdateScalars, + PostNestedCreate (..), + PostNestedUpsert (..), + PostsUpdate (..), + emptyPostsUpdate, + AuthorQuery (..), + AuthorUnique (..), + AuthorUniqueKey (..), + AuthorUniqueQuery (..), + emptyQuery, + uniqueQuery, + authorUniqueWhere, + OmitSelect (..), + Picked (..), + AuthorCreate (..), + AuthorRow (..), + AuthorSelect (..), + AuthorPicked (..), + authorSelect, + AuthorUpdate (..), + AuthorTable, + authorId + ) +where + +import Data.Maybe (isJust) +import Data.Text (Text) +import Data.UUID (UUID) +import Poppy.Internal.Generated + ( Db, + transactionEither, + fieldColumn, + toField, + ORMError (..), + fromUniqueRows, + requireFound, + uniqueOrFail, + OrderBy, + applyQueryModifiers, + matching, + selectColumns, + OmitSelect (..), + Picked (..), + prepareIncludeRootQuery, + Where, + and_, + eq + ) +import qualified Poppy.Internal.Generated as Delete + ( deleteMany, + deleteWhere, + whereDelete, + emptyDelete + ) +import qualified Poppy.Internal.Generated as Insert + ( insert, + insertMany, + upsert + ) +import qualified Poppy.Internal.Generated as Ops + ( findMany, + findManyWith, + findFirst, + findFirstWith, + count + ) +import qualified Poppy.Internal.Generated as Update + ( updateWhere, + updateMany + ) + +import Schema.Author (AuthorRow (..), AuthorSelect (..), AuthorPicked (..), authorSelect, authorSelectColumns, parseAuthorPicked, AuthorTable, authorId) +import qualified Schema.Author as AuthorSchema (AuthorCreate (..), AuthorUpdate (..)) + +import Schema.Include.Author (LoadAuthor (..), AuthorInclude (..), AuthorRead, toAuthorWithPicked) +import Schema.Post (PostRow (..), PostTable, postId, postAuthorId, PostCreate (..), PostUpdate (..)) +import qualified Schema.Client.Post as Post (PostUnique (..), postUniqueWhere) +import Schema.PostStatus (PostStatus (..)) + +data AuthorUnique + = ById UUID + deriving (Eq, Show) + +data AuthorUniqueKey + = OnId + deriving (Eq, Show) + +authorUniqueWhere :: AuthorUnique -> Where AuthorTable +authorUniqueWhere = \case + ById v1 -> eq authorId v1 + +authorConflictCols :: AuthorUniqueKey -> [Text] +authorConflictCols = \case + OnId -> ["id"] + +data PostNestedCreate + = CreatePost + { id :: Maybe UUID, title :: Text, status :: PostStatus + } + | ConnectPost Post.PostUnique + deriving (Show, Eq) +data PostNestedUpsert = PostNestedUpsert + { where_ :: Post.PostUnique + , create :: PostNestedCreate + , update :: PostUpdate + } + deriving (Show, Eq) +data PostsUpdate = PostsUpdate + { replaceWith :: Maybe [PostNestedCreate] + , create :: [PostNestedCreate] + , createMany :: [PostNestedCreate] + , connect :: [Post.PostUnique] + , delete :: [Post.PostUnique] + , update :: [(Post.PostUnique, PostUpdate)] + , upsert :: [PostNestedUpsert] + } + deriving (Show, Eq) + +emptyPostsUpdate :: PostsUpdate +emptyPostsUpdate = + PostsUpdate + { replaceWith = Nothing + , create = [] + , createMany = [] + , connect = [] + , delete = [] + , update = [] + , upsert = [] + } +data AuthorCreate = AuthorCreate + { id :: Maybe UUID, + name :: Text, + posts :: [PostNestedCreate] + } + deriving (Show, Eq) + +type AuthorCreateScalars = AuthorSchema.AuthorCreate + +toAuthorCreateScalars :: AuthorCreate -> AuthorCreateScalars +toAuthorCreateScalars input = + AuthorSchema.AuthorCreate + { id = input.id, + name = input.name + } +data AuthorUpdate = AuthorUpdate + { name :: Maybe Text, + posts :: Maybe PostsUpdate + } + deriving (Show, Eq) + +type AuthorUpdateScalars = AuthorSchema.AuthorUpdate + +toAuthorUpdateScalars :: AuthorUpdate -> AuthorUpdateScalars +toAuthorUpdateScalars input = + AuthorSchema.AuthorUpdate + { name = input.name + } + +create :: AuthorCreate -> Db (Either ORMError AuthorRow) +create input = + if hasAuthorNestedCreate input + then transactionEither (createWithNested input) + else Insert.insert @AuthorTable @AuthorRow (toAuthorCreateScalars input) + +hasAuthorNestedCreate :: AuthorCreate -> Bool +hasAuthorNestedCreate input = + not (null input.posts) + +createWithNested :: AuthorCreate -> Db (Either ORMError AuthorRow) +createWithNested input = do + rootResult <- Insert.insert @AuthorTable @AuthorRow (toAuthorCreateScalars input) + case rootResult of + Left err -> pure (Left err) + Right row -> do + nestedResult <- + sequenceNested + [ applyPostsCreate row.id input.posts + ] + case nestedResult of + Left err -> pure (Left err) + Right () -> pure (Right row) + +createMany :: [AuthorCreateScalars] -> Db (Either ORMError Int) +createMany = Insert.insertMany @AuthorTable + +update :: AuthorUnique -> AuthorUpdate -> Db (Either ORMError AuthorRow) +update key input = + if hasAuthorNestedUpdate input + then transactionEither (updateWithNested key input) + else Update.updateWhere @AuthorTable @AuthorRow (authorUniqueWhere key) (toAuthorUpdateScalars input) + +hasAuthorNestedUpdate :: AuthorUpdate -> Bool +hasAuthorNestedUpdate input = + isJust input.posts + +updateWithNested :: AuthorUnique -> AuthorUpdate -> Db (Either ORMError AuthorRow) +updateWithNested key input = do + updateResult <- Update.updateWhere @AuthorTable @AuthorRow (authorUniqueWhere key) (toAuthorUpdateScalars input) + case updateResult of + Left err -> pure (Left err) + Right row -> do + nestedResult <- + sequenceNested + [ maybe (pure (Right ())) (applyPostsUpdate row.id) input.posts + ] + case nestedResult of + Left err -> pure (Left err) + Right () -> pure (Right row) + +updateMany :: Where AuthorTable -> AuthorUpdateScalars -> Db (Either ORMError Int) +updateMany = Update.updateMany @AuthorTable + +upsert :: AuthorUniqueKey -> AuthorCreateScalars -> AuthorUpdateScalars -> Db (Either ORMError AuthorRow) +upsert key createInput updateInput = + Insert.upsert @AuthorTable @AuthorRow (authorConflictCols key) createInput updateInput + +sequenceNested :: [Db (Either ORMError ())] -> Db (Either ORMError ()) +sequenceNested [] = pure (Right ()) +sequenceNested (action : rest) = do + result <- action + case result of + Left err -> pure (Left err) + Right () -> sequenceNested rest +applyPostsCreate :: UUID -> [PostNestedCreate] -> Db (Either ORMError ()) +applyPostsCreate = insertPosts +applyPostsUpdate :: UUID -> PostsUpdate -> Db (Either ORMError ()) +applyPostsUpdate parentId ops = do + replaced <- case ops.replaceWith of + Nothing -> pure (Right ()) + Just items -> replacePosts parentId items + case replaced of + Left err -> pure (Left err) + Right () -> + sequenceNested + [ deletePosts parentId ops.delete + , updatePostsRows parentId ops.update + , upsertPosts parentId ops.upsert + , insertPosts parentId ops.create + , insertPosts parentId ops.createMany + , connectPosts parentId ops.connect + ] +replacePosts :: UUID -> [PostNestedCreate] -> Db (Either ORMError ()) +replacePosts parentId items = do + result <- + Delete.deleteWhere $ + Delete.whereDelete (fieldColumn postAuthorId <> " = ?") [toField parentId] (Delete.emptyDelete @PostTable) + case result of + Left err -> pure (Left err) + Right _ -> insertPosts parentId items +insertPosts :: UUID -> [PostNestedCreate] -> Db (Either ORMError ()) +insertPosts parentId = go + where + go [] = pure (Right ()) + go (nested : rest) = do + result <- case nested of + ConnectPost key -> connectPosts parentId [key] + CreatePost {id, title, status} -> do + inserted <- Insert.insert @PostTable @PostRow PostCreate + { id = id, + title = title, + status = status, + authorId = parentId + } + pure $ case inserted of + Left err -> Left err + Right _ -> Right () + case result of + Left err -> pure (Left err) + Right () -> go rest +deletePosts :: UUID -> [Post.PostUnique] -> Db (Either ORMError ()) +deletePosts _ [] = pure (Right ()) +deletePosts parentId keys = sequenceNested (map deleteOne keys) + where + deleteOne key = do + result <- Delete.deleteMany @PostTable + (Post.postUniqueWhere key `and_` eq postAuthorId parentId) + pure $ case result of + Left err -> Left err + Right _ -> Right () +updatePostsRows :: UUID -> [(Post.PostUnique, PostUpdate)] -> Db (Either ORMError ()) +updatePostsRows parentId = go + where + go [] = pure (Right ()) + go ((key, nested) : rest) = do + let patched = PostUpdate { authorId = Nothing, title = nested.title, status = nested.status } + result <- + Update.updateWhere @PostTable @PostRow + (Post.postUniqueWhere key `and_` eq postAuthorId parentId) + patched + case result of + Left err -> pure (Left err) + Right _ -> go rest +upsertPosts :: UUID -> [PostNestedUpsert] -> Db (Either ORMError ()) +upsertPosts parentId = go + where + go [] = pure (Right ()) + go (item : rest) = do + existing <- Ops.findMany @PostTable @PostRow (matching (Post.postUniqueWhere item.where_)) + result <- case fromUniqueRows existing of + Left err -> pure (Left err) + Right Nothing -> insertPosts parentId [item.create] + Right (Just row) -> + if row.authorId == parentId + then do + let patched = PostUpdate { authorId = Nothing, title = item.update.title, status = item.update.status } + updated <- + Update.updateWhere @PostTable @PostRow + (Post.postUniqueWhere item.where_ `and_` eq postAuthorId parentId) + patched + pure $ case updated of + Left err -> Left err + Right _ -> Right () + else pure (Left (UniqueViolation "nested upsert would reparent a row owned by another parent")) + case result of + Left err -> pure (Left err) + Right () -> go rest +connectPosts :: UUID -> [Post.PostUnique] -> Db (Either ORMError ()) +connectPosts _ [] = pure (Right ()) +connectPosts parentId keys = sequenceNested (map connectOne keys) + where + connectOne key = do + result <- + Update.updateWhere @PostTable @PostRow + (Post.postUniqueWhere key) + (PostUpdate + { authorId = Just parentId, + title = Nothing, + status = Nothing + }) + pure $ case result of + Left err -> Left err + Right _ -> Right () + +data AuthorQuery include select = AuthorQuery + { include_ :: include + , select_ :: select + , where_ :: Maybe (Where AuthorTable) + , orderBy_ :: [OrderBy AuthorTable] + , limit_ :: Maybe Int + , offset_ :: Maybe Int + } + +data AuthorUniqueQuery include select = AuthorUniqueQuery + { include_ :: include + , select_ :: select + , where_ :: AuthorUnique + } + +emptyQuery :: AuthorQuery () OmitSelect +emptyQuery = + AuthorQuery {include_ = (), select_ = OmitSelect, where_ = Nothing, orderBy_ = [], limit_ = Nothing, offset_ = Nothing} + +uniqueQuery :: AuthorUnique -> AuthorUniqueQuery () OmitSelect +uniqueQuery key = + AuthorUniqueQuery {include_ = (), select_ = OmitSelect, where_ = key} + +class ReadAuthor include select where + findMany :: AuthorQuery include select -> Db [AuthorRead include select] + findUnique :: AuthorUniqueQuery include select -> Db (Either ORMError (Maybe (AuthorRead include select))) + findUniqueOrFail :: AuthorUniqueQuery include select -> Db (Either ORMError (AuthorRead include select)) + findFirst :: AuthorQuery include select -> Db (Maybe (AuthorRead include select)) + findFirstOrFail :: AuthorQuery include select -> Db (Either ORMError (AuthorRead include select)) + +instance (LoadAuthor posts) => ReadAuthor (AuthorInclude posts) OmitSelect where + findMany AuthorQuery {include_, where_, orderBy_, limit_, offset_} = do + roots <- Ops.findMany @AuthorTable @AuthorRow (prepareIncludeRootQuery @AuthorTable (applyQueryModifiers where_ orderBy_ limit_ offset_)) + loadAuthor include_ roots + findUnique AuthorUniqueQuery {where_, include_} = do + let w = authorUniqueWhere where_ + roots <- Ops.findMany @AuthorTable @AuthorRow (prepareIncludeRootQuery @AuthorTable (matching w)) + rows <- loadAuthor include_ roots + pure (fromUniqueRows rows) + findUniqueOrFail q = uniqueOrFail <$> findUnique q + findFirst AuthorQuery {include_, where_, orderBy_, offset_} = do + roots <- Ops.findMany @AuthorTable @AuthorRow (prepareIncludeRootQuery @AuthorTable (applyQueryModifiers where_ orderBy_ (Just 1) offset_)) + loaded <- loadAuthor include_ roots + pure $ case loaded of + [] -> Nothing + (row : _) -> Just row + findFirstOrFail q = do + result <- findFirst q + pure $ requireFound result (RecordNotFound "No record found matching query") + +instance ReadAuthor () OmitSelect where + findMany AuthorQuery {where_, orderBy_, limit_, offset_} = + Ops.findMany @AuthorTable @AuthorRow (applyQueryModifiers where_ orderBy_ limit_ offset_) + findUnique AuthorUniqueQuery {where_} = do + let w = authorUniqueWhere where_ + rows <- Ops.findMany @AuthorTable @AuthorRow (matching w) + pure (fromUniqueRows rows) + findUniqueOrFail q = uniqueOrFail <$> findUnique q + findFirst AuthorQuery {where_, orderBy_, limit_, offset_} = + Ops.findFirst @AuthorTable @AuthorRow (applyQueryModifiers where_ orderBy_ limit_ offset_) + findFirstOrFail q = do + result <- findFirst q + pure $ requireFound result (RecordNotFound "No record found matching query") + +instance (LoadAuthor posts) => ReadAuthor (AuthorInclude posts) AuthorSelect where + findMany AuthorQuery {include_, select_, where_, orderBy_, limit_, offset_} = do + roots <- Ops.findMany @AuthorTable @AuthorRow (prepareIncludeRootQuery @AuthorTable (applyQueryModifiers where_ orderBy_ limit_ offset_)) + loaded <- loadAuthor include_ roots + pure $ map (toAuthorWithPicked select_) loaded + findUnique AuthorUniqueQuery {where_, include_, select_} = do + let w = authorUniqueWhere where_ + roots <- Ops.findMany @AuthorTable @AuthorRow (prepareIncludeRootQuery @AuthorTable (matching w)) + loaded <- loadAuthor include_ roots + let rows = map (toAuthorWithPicked select_) loaded + pure (fromUniqueRows rows) + findUniqueOrFail q = uniqueOrFail <$> findUnique q + findFirst AuthorQuery {select_, include_, where_, orderBy_, offset_} = do + roots <- Ops.findMany @AuthorTable @AuthorRow (prepareIncludeRootQuery @AuthorTable (applyQueryModifiers where_ orderBy_ (Just 1) offset_)) + loaded <- loadAuthor include_ roots + pure $ case loaded of + [] -> Nothing + (row : _) -> Just (toAuthorWithPicked select_ row) + findFirstOrFail q = do + result <- findFirst q + pure $ requireFound result (RecordNotFound "No record found matching query") + +instance ReadAuthor () AuthorSelect where + findMany AuthorQuery {select_, where_, orderBy_, limit_, offset_} = + Ops.findManyWith + (parseAuthorPicked select_) + (selectColumns (authorSelectColumns select_) . applyQueryModifiers where_ orderBy_ limit_ offset_) + findUnique AuthorUniqueQuery {where_, select_} = do + let w = authorUniqueWhere where_ + rows <- + Ops.findManyWith + (parseAuthorPicked select_) + (selectColumns (authorSelectColumns select_) . matching w) + pure (fromUniqueRows rows) + findUniqueOrFail q = uniqueOrFail <$> findUnique q + findFirst AuthorQuery {select_, where_, orderBy_, limit_, offset_} = + Ops.findFirstWith + (parseAuthorPicked select_) + (selectColumns (authorSelectColumns select_) . applyQueryModifiers where_ orderBy_ limit_ offset_) + findFirstOrFail q = do + result <- findFirst q + pure $ requireFound result (RecordNotFound "No record found matching query") + +count :: AuthorQuery include select -> Db Int +count AuthorQuery {where_, orderBy_, limit_, offset_} = + Ops.count @AuthorTable (applyQueryModifiers where_ orderBy_ limit_ offset_) + +delete :: AuthorUnique -> Db (Either ORMError Int) +delete key = + Delete.deleteMany @AuthorTable (authorUniqueWhere key) + +deleteMany :: Where AuthorTable -> Db (Either ORMError Int) +deleteMany = Delete.deleteMany @AuthorTable diff --git a/test/Schema/Client/Book.hs b/test/Schema/Client/Book.hs new file mode 100644 --- /dev/null +++ b/test/Schema/Client/Book.hs @@ -0,0 +1,487 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NoFieldSelectors #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +{- | Generated Client. Do not edit. + +Nested writes live on 'create' / 'update'. + create-time relation fields are [CreateChild | ConnectChild unique] + update-time relation fields are Maybe Update (replaceWith, create, connect, delete, update, upsert; + disconnect when the child foreign key is nullable) +-} +module Schema.Client.Book + ( findMany, + findUnique, + findUniqueOrFail, + findFirst, + findFirstOrFail, + count, + create, + createMany, + update, + updateMany, + upsert, + delete, + deleteMany, + BookCreateScalars, + BookUpdateScalars, + ChapterNestedCreate (..), + ChapterNestedUpsert (..), + ChaptersUpdate (..), + emptyChaptersUpdate, + BookQuery (..), + BookUnique (..), + BookUniqueKey (..), + BookUniqueQuery (..), + emptyQuery, + uniqueQuery, + bookUniqueWhere, + OmitSelect (..), + Picked (..), + BookCreate (..), + BookRow (..), + BookSelect (..), + BookPicked (..), + bookSelect, + BookUpdate (..), + BookTable, + bookId + ) +where + +import Data.Maybe (isJust) +import Data.Text (Text) +import Data.UUID (UUID) +import Poppy.Internal.Generated + ( Db, + transactionEither, + fieldColumn, + toField, + ORMError (..), + fromUniqueRows, + requireFound, + uniqueOrFail, + OrderBy, + applyQueryModifiers, + matching, + selectColumns, + OmitSelect (..), + Picked (..), + prepareIncludeRootQuery, + Where, + and_, + eq + ) +import qualified Poppy.Internal.Generated as Delete + ( deleteMany, + deleteWhere, + whereDelete, + emptyDelete + ) +import qualified Poppy.Internal.Generated as Insert + ( insert, + insertMany, + upsert + ) +import qualified Poppy.Internal.Generated as Ops + ( findMany, + findManyWith, + findFirst, + findFirstWith, + count + ) +import qualified Poppy.Internal.Generated as Update + ( updateWhere, + updateMany + ) + +import Schema.Book (BookRow (..), BookSelect (..), BookPicked (..), bookSelect, bookSelectColumns, parseBookPicked, BookTable, bookId) +import qualified Schema.Book as BookSchema (BookCreate (..), BookUpdate (..)) + +import Schema.Include.Book (LoadBook (..), BookInclude (..), BookRead, toBookWithPicked) +import Schema.Chapter (ChapterRow (..), ChapterTable, chapterId, chapterBookRef, ChapterCreate (..), ChapterUpdate (..)) +import qualified Schema.Client.Chapter as Chapter (ChapterUnique (..), chapterUniqueWhere) + +data BookUnique + = ById UUID + deriving (Eq, Show) + +data BookUniqueKey + = OnId + deriving (Eq, Show) + +bookUniqueWhere :: BookUnique -> Where BookTable +bookUniqueWhere = \case + ById v1 -> eq bookId v1 + +bookConflictCols :: BookUniqueKey -> [Text] +bookConflictCols = \case + OnId -> ["id"] + +data ChapterNestedCreate + = CreateChapter + { id :: Maybe UUID, heading :: Text + } + | ConnectChapter Chapter.ChapterUnique + deriving (Show, Eq) +data ChapterNestedUpsert = ChapterNestedUpsert + { where_ :: Chapter.ChapterUnique + , create :: ChapterNestedCreate + , update :: ChapterUpdate + } + deriving (Show, Eq) +data ChaptersUpdate = ChaptersUpdate + { replaceWith :: Maybe [ChapterNestedCreate] + , create :: [ChapterNestedCreate] + , createMany :: [ChapterNestedCreate] + , connect :: [Chapter.ChapterUnique] + , delete :: [Chapter.ChapterUnique] + , update :: [(Chapter.ChapterUnique, ChapterUpdate)] + , upsert :: [ChapterNestedUpsert] + } + deriving (Show, Eq) + +emptyChaptersUpdate :: ChaptersUpdate +emptyChaptersUpdate = + ChaptersUpdate + { replaceWith = Nothing + , create = [] + , createMany = [] + , connect = [] + , delete = [] + , update = [] + , upsert = [] + } +data BookCreate = BookCreate + { id :: Maybe UUID, + shelfId :: UUID, + title :: Text, + chapters :: [ChapterNestedCreate] + } + deriving (Show, Eq) + +type BookCreateScalars = BookSchema.BookCreate + +toBookCreateScalars :: BookCreate -> BookCreateScalars +toBookCreateScalars input = + BookSchema.BookCreate + { id = input.id, + shelfId = input.shelfId, + title = input.title + } +data BookUpdate = BookUpdate + { shelfId :: Maybe UUID, + title :: Maybe Text, + chapters :: Maybe ChaptersUpdate + } + deriving (Show, Eq) + +type BookUpdateScalars = BookSchema.BookUpdate + +toBookUpdateScalars :: BookUpdate -> BookUpdateScalars +toBookUpdateScalars input = + BookSchema.BookUpdate + { shelfId = input.shelfId, + title = input.title + } + +create :: BookCreate -> Db (Either ORMError BookRow) +create input = + if hasBookNestedCreate input + then transactionEither (createWithNested input) + else Insert.insert @BookTable @BookRow (toBookCreateScalars input) + +hasBookNestedCreate :: BookCreate -> Bool +hasBookNestedCreate input = + not (null input.chapters) + +createWithNested :: BookCreate -> Db (Either ORMError BookRow) +createWithNested input = do + rootResult <- Insert.insert @BookTable @BookRow (toBookCreateScalars input) + case rootResult of + Left err -> pure (Left err) + Right row -> do + nestedResult <- + sequenceNested + [ applyChaptersCreate row.id input.chapters + ] + case nestedResult of + Left err -> pure (Left err) + Right () -> pure (Right row) + +createMany :: [BookCreateScalars] -> Db (Either ORMError Int) +createMany = Insert.insertMany @BookTable + +update :: BookUnique -> BookUpdate -> Db (Either ORMError BookRow) +update key input = + if hasBookNestedUpdate input + then transactionEither (updateWithNested key input) + else Update.updateWhere @BookTable @BookRow (bookUniqueWhere key) (toBookUpdateScalars input) + +hasBookNestedUpdate :: BookUpdate -> Bool +hasBookNestedUpdate input = + isJust input.chapters + +updateWithNested :: BookUnique -> BookUpdate -> Db (Either ORMError BookRow) +updateWithNested key input = do + updateResult <- Update.updateWhere @BookTable @BookRow (bookUniqueWhere key) (toBookUpdateScalars input) + case updateResult of + Left err -> pure (Left err) + Right row -> do + nestedResult <- + sequenceNested + [ maybe (pure (Right ())) (applyChaptersUpdate row.id) input.chapters + ] + case nestedResult of + Left err -> pure (Left err) + Right () -> pure (Right row) + +updateMany :: Where BookTable -> BookUpdateScalars -> Db (Either ORMError Int) +updateMany = Update.updateMany @BookTable + +upsert :: BookUniqueKey -> BookCreateScalars -> BookUpdateScalars -> Db (Either ORMError BookRow) +upsert key createInput updateInput = + Insert.upsert @BookTable @BookRow (bookConflictCols key) createInput updateInput + +sequenceNested :: [Db (Either ORMError ())] -> Db (Either ORMError ()) +sequenceNested [] = pure (Right ()) +sequenceNested (action : rest) = do + result <- action + case result of + Left err -> pure (Left err) + Right () -> sequenceNested rest +applyChaptersCreate :: UUID -> [ChapterNestedCreate] -> Db (Either ORMError ()) +applyChaptersCreate = insertChapters +applyChaptersUpdate :: UUID -> ChaptersUpdate -> Db (Either ORMError ()) +applyChaptersUpdate parentId ops = do + replaced <- case ops.replaceWith of + Nothing -> pure (Right ()) + Just items -> replaceChapters parentId items + case replaced of + Left err -> pure (Left err) + Right () -> + sequenceNested + [ deleteChapters parentId ops.delete + , updateChaptersRows parentId ops.update + , upsertChapters parentId ops.upsert + , insertChapters parentId ops.create + , insertChapters parentId ops.createMany + , connectChapters parentId ops.connect + ] +replaceChapters :: UUID -> [ChapterNestedCreate] -> Db (Either ORMError ()) +replaceChapters parentId items = do + result <- + Delete.deleteWhere $ + Delete.whereDelete (fieldColumn chapterBookRef <> " = ?") [toField parentId] (Delete.emptyDelete @ChapterTable) + case result of + Left err -> pure (Left err) + Right _ -> insertChapters parentId items +insertChapters :: UUID -> [ChapterNestedCreate] -> Db (Either ORMError ()) +insertChapters parentId = go + where + go [] = pure (Right ()) + go (nested : rest) = do + result <- case nested of + ConnectChapter key -> connectChapters parentId [key] + CreateChapter {id, heading} -> do + inserted <- Insert.insert @ChapterTable @ChapterRow ChapterCreate + { id = id, + heading = heading, + bookRef = parentId + } + pure $ case inserted of + Left err -> Left err + Right _ -> Right () + case result of + Left err -> pure (Left err) + Right () -> go rest +deleteChapters :: UUID -> [Chapter.ChapterUnique] -> Db (Either ORMError ()) +deleteChapters _ [] = pure (Right ()) +deleteChapters parentId keys = sequenceNested (map deleteOne keys) + where + deleteOne key = do + result <- Delete.deleteMany @ChapterTable + (Chapter.chapterUniqueWhere key `and_` eq chapterBookRef parentId) + pure $ case result of + Left err -> Left err + Right _ -> Right () +updateChaptersRows :: UUID -> [(Chapter.ChapterUnique, ChapterUpdate)] -> Db (Either ORMError ()) +updateChaptersRows parentId = go + where + go [] = pure (Right ()) + go ((key, nested) : rest) = do + let patched = ChapterUpdate { bookRef = Nothing, heading = nested.heading } + result <- + Update.updateWhere @ChapterTable @ChapterRow + (Chapter.chapterUniqueWhere key `and_` eq chapterBookRef parentId) + patched + case result of + Left err -> pure (Left err) + Right _ -> go rest +upsertChapters :: UUID -> [ChapterNestedUpsert] -> Db (Either ORMError ()) +upsertChapters parentId = go + where + go [] = pure (Right ()) + go (item : rest) = do + existing <- Ops.findMany @ChapterTable @ChapterRow (matching (Chapter.chapterUniqueWhere item.where_)) + result <- case fromUniqueRows existing of + Left err -> pure (Left err) + Right Nothing -> insertChapters parentId [item.create] + Right (Just row) -> + if row.bookRef == parentId + then do + let patched = ChapterUpdate { bookRef = Nothing, heading = item.update.heading } + updated <- + Update.updateWhere @ChapterTable @ChapterRow + (Chapter.chapterUniqueWhere item.where_ `and_` eq chapterBookRef parentId) + patched + pure $ case updated of + Left err -> Left err + Right _ -> Right () + else pure (Left (UniqueViolation "nested upsert would reparent a row owned by another parent")) + case result of + Left err -> pure (Left err) + Right () -> go rest +connectChapters :: UUID -> [Chapter.ChapterUnique] -> Db (Either ORMError ()) +connectChapters _ [] = pure (Right ()) +connectChapters parentId keys = sequenceNested (map connectOne keys) + where + connectOne key = do + result <- + Update.updateWhere @ChapterTable @ChapterRow + (Chapter.chapterUniqueWhere key) + (ChapterUpdate + { bookRef = Just parentId, + heading = Nothing + }) + pure $ case result of + Left err -> Left err + Right _ -> Right () + +data BookQuery include select = BookQuery + { include_ :: include + , select_ :: select + , where_ :: Maybe (Where BookTable) + , orderBy_ :: [OrderBy BookTable] + , limit_ :: Maybe Int + , offset_ :: Maybe Int + } + +data BookUniqueQuery include select = BookUniqueQuery + { include_ :: include + , select_ :: select + , where_ :: BookUnique + } + +emptyQuery :: BookQuery () OmitSelect +emptyQuery = + BookQuery {include_ = (), select_ = OmitSelect, where_ = Nothing, orderBy_ = [], limit_ = Nothing, offset_ = Nothing} + +uniqueQuery :: BookUnique -> BookUniqueQuery () OmitSelect +uniqueQuery key = + BookUniqueQuery {include_ = (), select_ = OmitSelect, where_ = key} + +class ReadBook include select where + findMany :: BookQuery include select -> Db [BookRead include select] + findUnique :: BookUniqueQuery include select -> Db (Either ORMError (Maybe (BookRead include select))) + findUniqueOrFail :: BookUniqueQuery include select -> Db (Either ORMError (BookRead include select)) + findFirst :: BookQuery include select -> Db (Maybe (BookRead include select)) + findFirstOrFail :: BookQuery include select -> Db (Either ORMError (BookRead include select)) + +instance (LoadBook chapters) => ReadBook (BookInclude chapters) OmitSelect where + findMany BookQuery {include_, where_, orderBy_, limit_, offset_} = do + roots <- Ops.findMany @BookTable @BookRow (prepareIncludeRootQuery @BookTable (applyQueryModifiers where_ orderBy_ limit_ offset_)) + loadBook include_ roots + findUnique BookUniqueQuery {where_, include_} = do + let w = bookUniqueWhere where_ + roots <- Ops.findMany @BookTable @BookRow (prepareIncludeRootQuery @BookTable (matching w)) + rows <- loadBook include_ roots + pure (fromUniqueRows rows) + findUniqueOrFail q = uniqueOrFail <$> findUnique q + findFirst BookQuery {include_, where_, orderBy_, offset_} = do + roots <- Ops.findMany @BookTable @BookRow (prepareIncludeRootQuery @BookTable (applyQueryModifiers where_ orderBy_ (Just 1) offset_)) + loaded <- loadBook include_ roots + pure $ case loaded of + [] -> Nothing + (row : _) -> Just row + findFirstOrFail q = do + result <- findFirst q + pure $ requireFound result (RecordNotFound "No record found matching query") + +instance ReadBook () OmitSelect where + findMany BookQuery {where_, orderBy_, limit_, offset_} = + Ops.findMany @BookTable @BookRow (applyQueryModifiers where_ orderBy_ limit_ offset_) + findUnique BookUniqueQuery {where_} = do + let w = bookUniqueWhere where_ + rows <- Ops.findMany @BookTable @BookRow (matching w) + pure (fromUniqueRows rows) + findUniqueOrFail q = uniqueOrFail <$> findUnique q + findFirst BookQuery {where_, orderBy_, limit_, offset_} = + Ops.findFirst @BookTable @BookRow (applyQueryModifiers where_ orderBy_ limit_ offset_) + findFirstOrFail q = do + result <- findFirst q + pure $ requireFound result (RecordNotFound "No record found matching query") + +instance (LoadBook chapters) => ReadBook (BookInclude chapters) BookSelect where + findMany BookQuery {include_, select_, where_, orderBy_, limit_, offset_} = do + roots <- Ops.findMany @BookTable @BookRow (prepareIncludeRootQuery @BookTable (applyQueryModifiers where_ orderBy_ limit_ offset_)) + loaded <- loadBook include_ roots + pure $ map (toBookWithPicked select_) loaded + findUnique BookUniqueQuery {where_, include_, select_} = do + let w = bookUniqueWhere where_ + roots <- Ops.findMany @BookTable @BookRow (prepareIncludeRootQuery @BookTable (matching w)) + loaded <- loadBook include_ roots + let rows = map (toBookWithPicked select_) loaded + pure (fromUniqueRows rows) + findUniqueOrFail q = uniqueOrFail <$> findUnique q + findFirst BookQuery {select_, include_, where_, orderBy_, offset_} = do + roots <- Ops.findMany @BookTable @BookRow (prepareIncludeRootQuery @BookTable (applyQueryModifiers where_ orderBy_ (Just 1) offset_)) + loaded <- loadBook include_ roots + pure $ case loaded of + [] -> Nothing + (row : _) -> Just (toBookWithPicked select_ row) + findFirstOrFail q = do + result <- findFirst q + pure $ requireFound result (RecordNotFound "No record found matching query") + +instance ReadBook () BookSelect where + findMany BookQuery {select_, where_, orderBy_, limit_, offset_} = + Ops.findManyWith + (parseBookPicked select_) + (selectColumns (bookSelectColumns select_) . applyQueryModifiers where_ orderBy_ limit_ offset_) + findUnique BookUniqueQuery {where_, select_} = do + let w = bookUniqueWhere where_ + rows <- + Ops.findManyWith + (parseBookPicked select_) + (selectColumns (bookSelectColumns select_) . matching w) + pure (fromUniqueRows rows) + findUniqueOrFail q = uniqueOrFail <$> findUnique q + findFirst BookQuery {select_, where_, orderBy_, limit_, offset_} = + Ops.findFirstWith + (parseBookPicked select_) + (selectColumns (bookSelectColumns select_) . applyQueryModifiers where_ orderBy_ limit_ offset_) + findFirstOrFail q = do + result <- findFirst q + pure $ requireFound result (RecordNotFound "No record found matching query") + +count :: BookQuery include select -> Db Int +count BookQuery {where_, orderBy_, limit_, offset_} = + Ops.count @BookTable (applyQueryModifiers where_ orderBy_ limit_ offset_) + +delete :: BookUnique -> Db (Either ORMError Int) +delete key = + Delete.deleteMany @BookTable (bookUniqueWhere key) + +deleteMany :: Where BookTable -> Db (Either ORMError Int) +deleteMany = Delete.deleteMany @BookTable diff --git a/test/Schema/Client/Chapter.hs b/test/Schema/Client/Chapter.hs new file mode 100644 --- /dev/null +++ b/test/Schema/Client/Chapter.hs @@ -0,0 +1,487 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NoFieldSelectors #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +{- | Generated Client. Do not edit. + +Nested writes live on 'create' / 'update'. + create-time relation fields are [CreateChild | ConnectChild unique] + update-time relation fields are Maybe Update (replaceWith, create, connect, delete, update, upsert; + disconnect when the child foreign key is nullable) +-} +module Schema.Client.Chapter + ( findMany, + findUnique, + findUniqueOrFail, + findFirst, + findFirstOrFail, + count, + create, + createMany, + update, + updateMany, + upsert, + delete, + deleteMany, + ChapterCreateScalars, + ChapterUpdateScalars, + SectionNestedCreate (..), + SectionNestedUpsert (..), + SectionsUpdate (..), + emptySectionsUpdate, + ChapterQuery (..), + ChapterUnique (..), + ChapterUniqueKey (..), + ChapterUniqueQuery (..), + emptyQuery, + uniqueQuery, + chapterUniqueWhere, + OmitSelect (..), + Picked (..), + ChapterCreate (..), + ChapterRow (..), + ChapterSelect (..), + ChapterPicked (..), + chapterSelect, + ChapterUpdate (..), + ChapterTable, + chapterId + ) +where + +import Data.Maybe (isJust) +import Data.Text (Text) +import Data.UUID (UUID) +import Poppy.Internal.Generated + ( Db, + transactionEither, + fieldColumn, + toField, + ORMError (..), + fromUniqueRows, + requireFound, + uniqueOrFail, + OrderBy, + applyQueryModifiers, + matching, + selectColumns, + OmitSelect (..), + Picked (..), + prepareIncludeRootQuery, + Where, + and_, + eq + ) +import qualified Poppy.Internal.Generated as Delete + ( deleteMany, + deleteWhere, + whereDelete, + emptyDelete + ) +import qualified Poppy.Internal.Generated as Insert + ( insert, + insertMany, + upsert + ) +import qualified Poppy.Internal.Generated as Ops + ( findMany, + findManyWith, + findFirst, + findFirstWith, + count + ) +import qualified Poppy.Internal.Generated as Update + ( updateWhere, + updateMany + ) + +import Schema.Chapter (ChapterRow (..), ChapterSelect (..), ChapterPicked (..), chapterSelect, chapterSelectColumns, parseChapterPicked, ChapterTable, chapterId) +import qualified Schema.Chapter as ChapterSchema (ChapterCreate (..), ChapterUpdate (..)) + +import Schema.Include.Chapter (LoadChapter (..), ChapterInclude (..), ChapterRead, toChapterWithPicked) +import Schema.Section (SectionRow (..), SectionTable, sectionId, sectionChapterRef, SectionCreate (..), SectionUpdate (..)) +import qualified Schema.Client.Section as Section (SectionUnique (..), sectionUniqueWhere) + +data ChapterUnique + = ById UUID + deriving (Eq, Show) + +data ChapterUniqueKey + = OnId + deriving (Eq, Show) + +chapterUniqueWhere :: ChapterUnique -> Where ChapterTable +chapterUniqueWhere = \case + ById v1 -> eq chapterId v1 + +chapterConflictCols :: ChapterUniqueKey -> [Text] +chapterConflictCols = \case + OnId -> ["id"] + +data SectionNestedCreate + = CreateSection + { id :: Maybe UUID, label :: Text + } + | ConnectSection Section.SectionUnique + deriving (Show, Eq) +data SectionNestedUpsert = SectionNestedUpsert + { where_ :: Section.SectionUnique + , create :: SectionNestedCreate + , update :: SectionUpdate + } + deriving (Show, Eq) +data SectionsUpdate = SectionsUpdate + { replaceWith :: Maybe [SectionNestedCreate] + , create :: [SectionNestedCreate] + , createMany :: [SectionNestedCreate] + , connect :: [Section.SectionUnique] + , delete :: [Section.SectionUnique] + , update :: [(Section.SectionUnique, SectionUpdate)] + , upsert :: [SectionNestedUpsert] + } + deriving (Show, Eq) + +emptySectionsUpdate :: SectionsUpdate +emptySectionsUpdate = + SectionsUpdate + { replaceWith = Nothing + , create = [] + , createMany = [] + , connect = [] + , delete = [] + , update = [] + , upsert = [] + } +data ChapterCreate = ChapterCreate + { id :: Maybe UUID, + bookRef :: UUID, + heading :: Text, + sections :: [SectionNestedCreate] + } + deriving (Show, Eq) + +type ChapterCreateScalars = ChapterSchema.ChapterCreate + +toChapterCreateScalars :: ChapterCreate -> ChapterCreateScalars +toChapterCreateScalars input = + ChapterSchema.ChapterCreate + { id = input.id, + bookRef = input.bookRef, + heading = input.heading + } +data ChapterUpdate = ChapterUpdate + { bookRef :: Maybe UUID, + heading :: Maybe Text, + sections :: Maybe SectionsUpdate + } + deriving (Show, Eq) + +type ChapterUpdateScalars = ChapterSchema.ChapterUpdate + +toChapterUpdateScalars :: ChapterUpdate -> ChapterUpdateScalars +toChapterUpdateScalars input = + ChapterSchema.ChapterUpdate + { bookRef = input.bookRef, + heading = input.heading + } + +create :: ChapterCreate -> Db (Either ORMError ChapterRow) +create input = + if hasChapterNestedCreate input + then transactionEither (createWithNested input) + else Insert.insert @ChapterTable @ChapterRow (toChapterCreateScalars input) + +hasChapterNestedCreate :: ChapterCreate -> Bool +hasChapterNestedCreate input = + not (null input.sections) + +createWithNested :: ChapterCreate -> Db (Either ORMError ChapterRow) +createWithNested input = do + rootResult <- Insert.insert @ChapterTable @ChapterRow (toChapterCreateScalars input) + case rootResult of + Left err -> pure (Left err) + Right row -> do + nestedResult <- + sequenceNested + [ applySectionsCreate row.id input.sections + ] + case nestedResult of + Left err -> pure (Left err) + Right () -> pure (Right row) + +createMany :: [ChapterCreateScalars] -> Db (Either ORMError Int) +createMany = Insert.insertMany @ChapterTable + +update :: ChapterUnique -> ChapterUpdate -> Db (Either ORMError ChapterRow) +update key input = + if hasChapterNestedUpdate input + then transactionEither (updateWithNested key input) + else Update.updateWhere @ChapterTable @ChapterRow (chapterUniqueWhere key) (toChapterUpdateScalars input) + +hasChapterNestedUpdate :: ChapterUpdate -> Bool +hasChapterNestedUpdate input = + isJust input.sections + +updateWithNested :: ChapterUnique -> ChapterUpdate -> Db (Either ORMError ChapterRow) +updateWithNested key input = do + updateResult <- Update.updateWhere @ChapterTable @ChapterRow (chapterUniqueWhere key) (toChapterUpdateScalars input) + case updateResult of + Left err -> pure (Left err) + Right row -> do + nestedResult <- + sequenceNested + [ maybe (pure (Right ())) (applySectionsUpdate row.id) input.sections + ] + case nestedResult of + Left err -> pure (Left err) + Right () -> pure (Right row) + +updateMany :: Where ChapterTable -> ChapterUpdateScalars -> Db (Either ORMError Int) +updateMany = Update.updateMany @ChapterTable + +upsert :: ChapterUniqueKey -> ChapterCreateScalars -> ChapterUpdateScalars -> Db (Either ORMError ChapterRow) +upsert key createInput updateInput = + Insert.upsert @ChapterTable @ChapterRow (chapterConflictCols key) createInput updateInput + +sequenceNested :: [Db (Either ORMError ())] -> Db (Either ORMError ()) +sequenceNested [] = pure (Right ()) +sequenceNested (action : rest) = do + result <- action + case result of + Left err -> pure (Left err) + Right () -> sequenceNested rest +applySectionsCreate :: UUID -> [SectionNestedCreate] -> Db (Either ORMError ()) +applySectionsCreate = insertSections +applySectionsUpdate :: UUID -> SectionsUpdate -> Db (Either ORMError ()) +applySectionsUpdate parentId ops = do + replaced <- case ops.replaceWith of + Nothing -> pure (Right ()) + Just items -> replaceSections parentId items + case replaced of + Left err -> pure (Left err) + Right () -> + sequenceNested + [ deleteSections parentId ops.delete + , updateSectionsRows parentId ops.update + , upsertSections parentId ops.upsert + , insertSections parentId ops.create + , insertSections parentId ops.createMany + , connectSections parentId ops.connect + ] +replaceSections :: UUID -> [SectionNestedCreate] -> Db (Either ORMError ()) +replaceSections parentId items = do + result <- + Delete.deleteWhere $ + Delete.whereDelete (fieldColumn sectionChapterRef <> " = ?") [toField parentId] (Delete.emptyDelete @SectionTable) + case result of + Left err -> pure (Left err) + Right _ -> insertSections parentId items +insertSections :: UUID -> [SectionNestedCreate] -> Db (Either ORMError ()) +insertSections parentId = go + where + go [] = pure (Right ()) + go (nested : rest) = do + result <- case nested of + ConnectSection key -> connectSections parentId [key] + CreateSection {id, label} -> do + inserted <- Insert.insert @SectionTable @SectionRow SectionCreate + { id = id, + label = label, + chapterRef = parentId + } + pure $ case inserted of + Left err -> Left err + Right _ -> Right () + case result of + Left err -> pure (Left err) + Right () -> go rest +deleteSections :: UUID -> [Section.SectionUnique] -> Db (Either ORMError ()) +deleteSections _ [] = pure (Right ()) +deleteSections parentId keys = sequenceNested (map deleteOne keys) + where + deleteOne key = do + result <- Delete.deleteMany @SectionTable + (Section.sectionUniqueWhere key `and_` eq sectionChapterRef parentId) + pure $ case result of + Left err -> Left err + Right _ -> Right () +updateSectionsRows :: UUID -> [(Section.SectionUnique, SectionUpdate)] -> Db (Either ORMError ()) +updateSectionsRows parentId = go + where + go [] = pure (Right ()) + go ((key, nested) : rest) = do + let patched = SectionUpdate { chapterRef = Nothing, label = nested.label } + result <- + Update.updateWhere @SectionTable @SectionRow + (Section.sectionUniqueWhere key `and_` eq sectionChapterRef parentId) + patched + case result of + Left err -> pure (Left err) + Right _ -> go rest +upsertSections :: UUID -> [SectionNestedUpsert] -> Db (Either ORMError ()) +upsertSections parentId = go + where + go [] = pure (Right ()) + go (item : rest) = do + existing <- Ops.findMany @SectionTable @SectionRow (matching (Section.sectionUniqueWhere item.where_)) + result <- case fromUniqueRows existing of + Left err -> pure (Left err) + Right Nothing -> insertSections parentId [item.create] + Right (Just row) -> + if row.chapterRef == parentId + then do + let patched = SectionUpdate { chapterRef = Nothing, label = item.update.label } + updated <- + Update.updateWhere @SectionTable @SectionRow + (Section.sectionUniqueWhere item.where_ `and_` eq sectionChapterRef parentId) + patched + pure $ case updated of + Left err -> Left err + Right _ -> Right () + else pure (Left (UniqueViolation "nested upsert would reparent a row owned by another parent")) + case result of + Left err -> pure (Left err) + Right () -> go rest +connectSections :: UUID -> [Section.SectionUnique] -> Db (Either ORMError ()) +connectSections _ [] = pure (Right ()) +connectSections parentId keys = sequenceNested (map connectOne keys) + where + connectOne key = do + result <- + Update.updateWhere @SectionTable @SectionRow + (Section.sectionUniqueWhere key) + (SectionUpdate + { chapterRef = Just parentId, + label = Nothing + }) + pure $ case result of + Left err -> Left err + Right _ -> Right () + +data ChapterQuery include select = ChapterQuery + { include_ :: include + , select_ :: select + , where_ :: Maybe (Where ChapterTable) + , orderBy_ :: [OrderBy ChapterTable] + , limit_ :: Maybe Int + , offset_ :: Maybe Int + } + +data ChapterUniqueQuery include select = ChapterUniqueQuery + { include_ :: include + , select_ :: select + , where_ :: ChapterUnique + } + +emptyQuery :: ChapterQuery () OmitSelect +emptyQuery = + ChapterQuery {include_ = (), select_ = OmitSelect, where_ = Nothing, orderBy_ = [], limit_ = Nothing, offset_ = Nothing} + +uniqueQuery :: ChapterUnique -> ChapterUniqueQuery () OmitSelect +uniqueQuery key = + ChapterUniqueQuery {include_ = (), select_ = OmitSelect, where_ = key} + +class ReadChapter include select where + findMany :: ChapterQuery include select -> Db [ChapterRead include select] + findUnique :: ChapterUniqueQuery include select -> Db (Either ORMError (Maybe (ChapterRead include select))) + findUniqueOrFail :: ChapterUniqueQuery include select -> Db (Either ORMError (ChapterRead include select)) + findFirst :: ChapterQuery include select -> Db (Maybe (ChapterRead include select)) + findFirstOrFail :: ChapterQuery include select -> Db (Either ORMError (ChapterRead include select)) + +instance (LoadChapter sections) => ReadChapter (ChapterInclude sections) OmitSelect where + findMany ChapterQuery {include_, where_, orderBy_, limit_, offset_} = do + roots <- Ops.findMany @ChapterTable @ChapterRow (prepareIncludeRootQuery @ChapterTable (applyQueryModifiers where_ orderBy_ limit_ offset_)) + loadChapter include_ roots + findUnique ChapterUniqueQuery {where_, include_} = do + let w = chapterUniqueWhere where_ + roots <- Ops.findMany @ChapterTable @ChapterRow (prepareIncludeRootQuery @ChapterTable (matching w)) + rows <- loadChapter include_ roots + pure (fromUniqueRows rows) + findUniqueOrFail q = uniqueOrFail <$> findUnique q + findFirst ChapterQuery {include_, where_, orderBy_, offset_} = do + roots <- Ops.findMany @ChapterTable @ChapterRow (prepareIncludeRootQuery @ChapterTable (applyQueryModifiers where_ orderBy_ (Just 1) offset_)) + loaded <- loadChapter include_ roots + pure $ case loaded of + [] -> Nothing + (row : _) -> Just row + findFirstOrFail q = do + result <- findFirst q + pure $ requireFound result (RecordNotFound "No record found matching query") + +instance ReadChapter () OmitSelect where + findMany ChapterQuery {where_, orderBy_, limit_, offset_} = + Ops.findMany @ChapterTable @ChapterRow (applyQueryModifiers where_ orderBy_ limit_ offset_) + findUnique ChapterUniqueQuery {where_} = do + let w = chapterUniqueWhere where_ + rows <- Ops.findMany @ChapterTable @ChapterRow (matching w) + pure (fromUniqueRows rows) + findUniqueOrFail q = uniqueOrFail <$> findUnique q + findFirst ChapterQuery {where_, orderBy_, limit_, offset_} = + Ops.findFirst @ChapterTable @ChapterRow (applyQueryModifiers where_ orderBy_ limit_ offset_) + findFirstOrFail q = do + result <- findFirst q + pure $ requireFound result (RecordNotFound "No record found matching query") + +instance (LoadChapter sections) => ReadChapter (ChapterInclude sections) ChapterSelect where + findMany ChapterQuery {include_, select_, where_, orderBy_, limit_, offset_} = do + roots <- Ops.findMany @ChapterTable @ChapterRow (prepareIncludeRootQuery @ChapterTable (applyQueryModifiers where_ orderBy_ limit_ offset_)) + loaded <- loadChapter include_ roots + pure $ map (toChapterWithPicked select_) loaded + findUnique ChapterUniqueQuery {where_, include_, select_} = do + let w = chapterUniqueWhere where_ + roots <- Ops.findMany @ChapterTable @ChapterRow (prepareIncludeRootQuery @ChapterTable (matching w)) + loaded <- loadChapter include_ roots + let rows = map (toChapterWithPicked select_) loaded + pure (fromUniqueRows rows) + findUniqueOrFail q = uniqueOrFail <$> findUnique q + findFirst ChapterQuery {select_, include_, where_, orderBy_, offset_} = do + roots <- Ops.findMany @ChapterTable @ChapterRow (prepareIncludeRootQuery @ChapterTable (applyQueryModifiers where_ orderBy_ (Just 1) offset_)) + loaded <- loadChapter include_ roots + pure $ case loaded of + [] -> Nothing + (row : _) -> Just (toChapterWithPicked select_ row) + findFirstOrFail q = do + result <- findFirst q + pure $ requireFound result (RecordNotFound "No record found matching query") + +instance ReadChapter () ChapterSelect where + findMany ChapterQuery {select_, where_, orderBy_, limit_, offset_} = + Ops.findManyWith + (parseChapterPicked select_) + (selectColumns (chapterSelectColumns select_) . applyQueryModifiers where_ orderBy_ limit_ offset_) + findUnique ChapterUniqueQuery {where_, select_} = do + let w = chapterUniqueWhere where_ + rows <- + Ops.findManyWith + (parseChapterPicked select_) + (selectColumns (chapterSelectColumns select_) . matching w) + pure (fromUniqueRows rows) + findUniqueOrFail q = uniqueOrFail <$> findUnique q + findFirst ChapterQuery {select_, where_, orderBy_, limit_, offset_} = + Ops.findFirstWith + (parseChapterPicked select_) + (selectColumns (chapterSelectColumns select_) . applyQueryModifiers where_ orderBy_ limit_ offset_) + findFirstOrFail q = do + result <- findFirst q + pure $ requireFound result (RecordNotFound "No record found matching query") + +count :: ChapterQuery include select -> Db Int +count ChapterQuery {where_, orderBy_, limit_, offset_} = + Ops.count @ChapterTable (applyQueryModifiers where_ orderBy_ limit_ offset_) + +delete :: ChapterUnique -> Db (Either ORMError Int) +delete key = + Delete.deleteMany @ChapterTable (chapterUniqueWhere key) + +deleteMany :: Where ChapterTable -> Db (Either ORMError Int) +deleteMany = Delete.deleteMany @ChapterTable diff --git a/test/Schema/Client/Comment.hs b/test/Schema/Client/Comment.hs new file mode 100644 --- /dev/null +++ b/test/Schema/Client/Comment.hs @@ -0,0 +1,504 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NoFieldSelectors #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +{- | Generated Client. Do not edit. + +Nested writes live on 'create' / 'update'. + create-time relation fields are [CreateChild | ConnectChild unique] + update-time relation fields are Maybe Update (replaceWith, create, connect, delete, update, upsert; + disconnect when the child foreign key is nullable) +-} +module Schema.Client.Comment + ( findMany, + findUnique, + findUniqueOrFail, + findFirst, + findFirstOrFail, + count, + create, + createMany, + update, + updateMany, + upsert, + delete, + deleteMany, + CommentCreateScalars, + CommentUpdateScalars, + CommentNestedCreate (..), + CommentNestedUpsert (..), + RepliesUpdate (..), + emptyRepliesUpdate, + CommentQuery (..), + CommentUnique (..), + CommentUniqueKey (..), + CommentUniqueQuery (..), + emptyQuery, + uniqueQuery, + commentUniqueWhere, + OmitSelect (..), + Picked (..), + CommentCreate (..), + CommentRow (..), + CommentSelect (..), + CommentPicked (..), + commentSelect, + CommentUpdate (..), + CommentTable, + commentId + ) +where + +import Data.Maybe (isJust) +import Data.Text (Text) +import Data.UUID (UUID) +import Poppy.Internal.Generated + ( Db, + transactionEither, + fieldColumn, + toField, + NullableValue (..), + ORMError (..), + fromUniqueRows, + requireFound, + uniqueOrFail, + OrderBy, + applyQueryModifiers, + matching, + selectColumns, + OmitSelect (..), + Picked (..), + prepareIncludeRootQuery, + Where, + and_, + eq + ) +import qualified Poppy.Internal.Generated as Delete + ( deleteMany, + deleteWhere, + whereDelete, + emptyDelete + ) +import qualified Poppy.Internal.Generated as Insert + ( insert, + insertMany, + upsert + ) +import qualified Poppy.Internal.Generated as Ops + ( findMany, + findManyWith, + findFirst, + findFirstWith, + count + ) +import qualified Poppy.Internal.Generated as Update + ( updateWhere, + updateMany + ) + +import Schema.Comment (CommentRow (..), CommentSelect (..), CommentPicked (..), commentSelect, commentSelectColumns, parseCommentPicked, CommentTable, commentId, commentParentId) +import qualified Schema.Comment as CommentSchema (CommentCreate (..), CommentUpdate (..)) + +import Schema.Include.Comment (LoadComment (..), CommentInclude (..), CommentRead, toCommentWithPicked) + +data CommentUnique + = ById UUID + deriving (Eq, Show) + +data CommentUniqueKey + = OnId + deriving (Eq, Show) + +commentUniqueWhere :: CommentUnique -> Where CommentTable +commentUniqueWhere = \case + ById v1 -> eq commentId v1 + +commentConflictCols :: CommentUniqueKey -> [Text] +commentConflictCols = \case + OnId -> ["id"] + +data CommentNestedCreate + = CreateComment + { id :: Maybe UUID, body :: Text + } + | ConnectComment CommentUnique + deriving (Show, Eq) +data CommentNestedUpsert = CommentNestedUpsert + { where_ :: CommentUnique + , create :: CommentNestedCreate + , update :: CommentSchema.CommentUpdate + } + deriving (Show, Eq) +data RepliesUpdate = RepliesUpdate + { replaceWith :: Maybe [CommentNestedCreate] + , create :: [CommentNestedCreate] + , createMany :: [CommentNestedCreate] + , connect :: [CommentUnique] + , delete :: [CommentUnique] + , update :: [(CommentUnique, CommentSchema.CommentUpdate)] + , upsert :: [CommentNestedUpsert] + , disconnect :: [CommentUnique] + } + deriving (Show, Eq) + +emptyRepliesUpdate :: RepliesUpdate +emptyRepliesUpdate = + RepliesUpdate + { replaceWith = Nothing + , create = [] + , createMany = [] + , connect = [] + , delete = [] + , update = [] + , upsert = [] + , disconnect = [] + } +data CommentCreate = CommentCreate + { id :: Maybe UUID, + parentId :: NullableValue UUID, + body :: Text, + replies :: [CommentNestedCreate] + } + deriving (Show, Eq) + +type CommentCreateScalars = CommentSchema.CommentCreate + +toCommentCreateScalars :: CommentCreate -> CommentCreateScalars +toCommentCreateScalars input = + CommentSchema.CommentCreate + { id = input.id, + parentId = input.parentId, + body = input.body + } +data CommentUpdate = CommentUpdate + { parentId :: NullableValue UUID, + body :: Maybe Text, + replies :: Maybe RepliesUpdate + } + deriving (Show, Eq) + +type CommentUpdateScalars = CommentSchema.CommentUpdate + +toCommentUpdateScalars :: CommentUpdate -> CommentUpdateScalars +toCommentUpdateScalars input = + CommentSchema.CommentUpdate + { parentId = input.parentId, + body = input.body + } + +create :: CommentCreate -> Db (Either ORMError CommentRow) +create input = + if hasCommentNestedCreate input + then transactionEither (createWithNested input) + else Insert.insert @CommentTable @CommentRow (toCommentCreateScalars input) + +hasCommentNestedCreate :: CommentCreate -> Bool +hasCommentNestedCreate input = + not (null input.replies) + +createWithNested :: CommentCreate -> Db (Either ORMError CommentRow) +createWithNested input = do + rootResult <- Insert.insert @CommentTable @CommentRow (toCommentCreateScalars input) + case rootResult of + Left err -> pure (Left err) + Right row -> do + nestedResult <- + sequenceNested + [ applyRepliesCreate row.id input.replies + ] + case nestedResult of + Left err -> pure (Left err) + Right () -> pure (Right row) + +createMany :: [CommentCreateScalars] -> Db (Either ORMError Int) +createMany = Insert.insertMany @CommentTable + +update :: CommentUnique -> CommentUpdate -> Db (Either ORMError CommentRow) +update key input = + if hasCommentNestedUpdate input + then transactionEither (updateWithNested key input) + else Update.updateWhere @CommentTable @CommentRow (commentUniqueWhere key) (toCommentUpdateScalars input) + +hasCommentNestedUpdate :: CommentUpdate -> Bool +hasCommentNestedUpdate input = + isJust input.replies + +updateWithNested :: CommentUnique -> CommentUpdate -> Db (Either ORMError CommentRow) +updateWithNested key input = do + updateResult <- Update.updateWhere @CommentTable @CommentRow (commentUniqueWhere key) (toCommentUpdateScalars input) + case updateResult of + Left err -> pure (Left err) + Right row -> do + nestedResult <- + sequenceNested + [ maybe (pure (Right ())) (applyRepliesUpdate row.id) input.replies + ] + case nestedResult of + Left err -> pure (Left err) + Right () -> pure (Right row) + +updateMany :: Where CommentTable -> CommentUpdateScalars -> Db (Either ORMError Int) +updateMany = Update.updateMany @CommentTable + +upsert :: CommentUniqueKey -> CommentCreateScalars -> CommentUpdateScalars -> Db (Either ORMError CommentRow) +upsert key createInput updateInput = + Insert.upsert @CommentTable @CommentRow (commentConflictCols key) createInput updateInput + +sequenceNested :: [Db (Either ORMError ())] -> Db (Either ORMError ()) +sequenceNested [] = pure (Right ()) +sequenceNested (action : rest) = do + result <- action + case result of + Left err -> pure (Left err) + Right () -> sequenceNested rest +applyRepliesCreate :: UUID -> [CommentNestedCreate] -> Db (Either ORMError ()) +applyRepliesCreate = insertReplies +applyRepliesUpdate :: UUID -> RepliesUpdate -> Db (Either ORMError ()) +applyRepliesUpdate parentId ops = do + replaced <- case ops.replaceWith of + Nothing -> pure (Right ()) + Just items -> replaceReplies parentId items + case replaced of + Left err -> pure (Left err) + Right () -> + sequenceNested + [ deleteReplies parentId ops.delete + , updateRepliesRows parentId ops.update + , upsertReplies parentId ops.upsert + , insertReplies parentId ops.create + , insertReplies parentId ops.createMany + , connectReplies parentId ops.connect + , disconnectReplies parentId ops.disconnect + ] +replaceReplies :: UUID -> [CommentNestedCreate] -> Db (Either ORMError ()) +replaceReplies parentId items = do + result <- + Delete.deleteWhere $ + Delete.whereDelete (fieldColumn commentParentId <> " = ?") [toField parentId] (Delete.emptyDelete @CommentTable) + case result of + Left err -> pure (Left err) + Right _ -> insertReplies parentId items +insertReplies :: UUID -> [CommentNestedCreate] -> Db (Either ORMError ()) +insertReplies parentId = go + where + go [] = pure (Right ()) + go (nested : rest) = do + result <- case nested of + ConnectComment key -> connectReplies parentId [key] + CreateComment {id, body} -> do + inserted <- Insert.insert @CommentTable @CommentRow CommentSchema.CommentCreate + { id = id, + body = body, + parentId = Value parentId + } + pure $ case inserted of + Left err -> Left err + Right _ -> Right () + case result of + Left err -> pure (Left err) + Right () -> go rest +deleteReplies :: UUID -> [CommentUnique] -> Db (Either ORMError ()) +deleteReplies _ [] = pure (Right ()) +deleteReplies parentId keys = sequenceNested (map deleteOne keys) + where + deleteOne key = do + result <- Delete.deleteMany @CommentTable + (commentUniqueWhere key `and_` eq commentParentId parentId) + pure $ case result of + Left err -> Left err + Right _ -> Right () +updateRepliesRows :: UUID -> [(CommentUnique, CommentSchema.CommentUpdate)] -> Db (Either ORMError ()) +updateRepliesRows parentId = go + where + go [] = pure (Right ()) + go ((key, nested) : rest) = do + let patched = CommentSchema.CommentUpdate { parentId = Omit, body = nested.body } + result <- + Update.updateWhere @CommentTable @CommentRow + (commentUniqueWhere key `and_` eq commentParentId parentId) + patched + case result of + Left err -> pure (Left err) + Right _ -> go rest +upsertReplies :: UUID -> [CommentNestedUpsert] -> Db (Either ORMError ()) +upsertReplies parentId = go + where + go [] = pure (Right ()) + go (item : rest) = do + existing <- Ops.findMany @CommentTable @CommentRow (matching (commentUniqueWhere item.where_)) + result <- case fromUniqueRows existing of + Left err -> pure (Left err) + Right Nothing -> insertReplies parentId [item.create] + Right (Just row) -> + if row.parentId == Just parentId + then do + let patched = CommentSchema.CommentUpdate { parentId = Omit, body = item.update.body } + updated <- + Update.updateWhere @CommentTable @CommentRow + (commentUniqueWhere item.where_ `and_` eq commentParentId parentId) + patched + pure $ case updated of + Left err -> Left err + Right _ -> Right () + else pure (Left (UniqueViolation "nested upsert would reparent a row owned by another parent")) + case result of + Left err -> pure (Left err) + Right () -> go rest +connectReplies :: UUID -> [CommentUnique] -> Db (Either ORMError ()) +connectReplies _ [] = pure (Right ()) +connectReplies parentId keys = sequenceNested (map connectOne keys) + where + connectOne key = do + result <- + Update.updateWhere @CommentTable @CommentRow + (commentUniqueWhere key) + (CommentSchema.CommentUpdate + { parentId = Value parentId, + body = Nothing + }) + pure $ case result of + Left err -> Left err + Right _ -> Right () +disconnectReplies :: UUID -> [CommentUnique] -> Db (Either ORMError ()) +disconnectReplies _ [] = pure (Right ()) +disconnectReplies parentId keys = sequenceNested (map disconnectOne keys) + where + disconnectOne key = do + result <- + Update.updateWhere @CommentTable @CommentRow + (commentUniqueWhere key `and_` eq commentParentId parentId) + (CommentSchema.CommentUpdate + { parentId = Null, + body = Nothing + }) + pure $ case result of + Left err -> Left err + Right _ -> Right () + +data CommentQuery include select = CommentQuery + { include_ :: include + , select_ :: select + , where_ :: Maybe (Where CommentTable) + , orderBy_ :: [OrderBy CommentTable] + , limit_ :: Maybe Int + , offset_ :: Maybe Int + } + +data CommentUniqueQuery include select = CommentUniqueQuery + { include_ :: include + , select_ :: select + , where_ :: CommentUnique + } + +emptyQuery :: CommentQuery () OmitSelect +emptyQuery = + CommentQuery {include_ = (), select_ = OmitSelect, where_ = Nothing, orderBy_ = [], limit_ = Nothing, offset_ = Nothing} + +uniqueQuery :: CommentUnique -> CommentUniqueQuery () OmitSelect +uniqueQuery key = + CommentUniqueQuery {include_ = (), select_ = OmitSelect, where_ = key} + +class ReadComment include select where + findMany :: CommentQuery include select -> Db [CommentRead include select] + findUnique :: CommentUniqueQuery include select -> Db (Either ORMError (Maybe (CommentRead include select))) + findUniqueOrFail :: CommentUniqueQuery include select -> Db (Either ORMError (CommentRead include select)) + findFirst :: CommentQuery include select -> Db (Maybe (CommentRead include select)) + findFirstOrFail :: CommentQuery include select -> Db (Either ORMError (CommentRead include select)) + +instance (LoadComment replies) => ReadComment (CommentInclude replies) OmitSelect where + findMany CommentQuery {include_, where_, orderBy_, limit_, offset_} = do + roots <- Ops.findMany @CommentTable @CommentRow (prepareIncludeRootQuery @CommentTable (applyQueryModifiers where_ orderBy_ limit_ offset_)) + loadComment include_ roots + findUnique CommentUniqueQuery {where_, include_} = do + let w = commentUniqueWhere where_ + roots <- Ops.findMany @CommentTable @CommentRow (prepareIncludeRootQuery @CommentTable (matching w)) + rows <- loadComment include_ roots + pure (fromUniqueRows rows) + findUniqueOrFail q = uniqueOrFail <$> findUnique q + findFirst CommentQuery {include_, where_, orderBy_, offset_} = do + roots <- Ops.findMany @CommentTable @CommentRow (prepareIncludeRootQuery @CommentTable (applyQueryModifiers where_ orderBy_ (Just 1) offset_)) + loaded <- loadComment include_ roots + pure $ case loaded of + [] -> Nothing + (row : _) -> Just row + findFirstOrFail q = do + result <- findFirst q + pure $ requireFound result (RecordNotFound "No record found matching query") + +instance ReadComment () OmitSelect where + findMany CommentQuery {where_, orderBy_, limit_, offset_} = + Ops.findMany @CommentTable @CommentRow (applyQueryModifiers where_ orderBy_ limit_ offset_) + findUnique CommentUniqueQuery {where_} = do + let w = commentUniqueWhere where_ + rows <- Ops.findMany @CommentTable @CommentRow (matching w) + pure (fromUniqueRows rows) + findUniqueOrFail q = uniqueOrFail <$> findUnique q + findFirst CommentQuery {where_, orderBy_, limit_, offset_} = + Ops.findFirst @CommentTable @CommentRow (applyQueryModifiers where_ orderBy_ limit_ offset_) + findFirstOrFail q = do + result <- findFirst q + pure $ requireFound result (RecordNotFound "No record found matching query") + +instance (LoadComment replies) => ReadComment (CommentInclude replies) CommentSelect where + findMany CommentQuery {include_, select_, where_, orderBy_, limit_, offset_} = do + roots <- Ops.findMany @CommentTable @CommentRow (prepareIncludeRootQuery @CommentTable (applyQueryModifiers where_ orderBy_ limit_ offset_)) + loaded <- loadComment include_ roots + pure $ map (toCommentWithPicked select_) loaded + findUnique CommentUniqueQuery {where_, include_, select_} = do + let w = commentUniqueWhere where_ + roots <- Ops.findMany @CommentTable @CommentRow (prepareIncludeRootQuery @CommentTable (matching w)) + loaded <- loadComment include_ roots + let rows = map (toCommentWithPicked select_) loaded + pure (fromUniqueRows rows) + findUniqueOrFail q = uniqueOrFail <$> findUnique q + findFirst CommentQuery {select_, include_, where_, orderBy_, offset_} = do + roots <- Ops.findMany @CommentTable @CommentRow (prepareIncludeRootQuery @CommentTable (applyQueryModifiers where_ orderBy_ (Just 1) offset_)) + loaded <- loadComment include_ roots + pure $ case loaded of + [] -> Nothing + (row : _) -> Just (toCommentWithPicked select_ row) + findFirstOrFail q = do + result <- findFirst q + pure $ requireFound result (RecordNotFound "No record found matching query") + +instance ReadComment () CommentSelect where + findMany CommentQuery {select_, where_, orderBy_, limit_, offset_} = + Ops.findManyWith + (parseCommentPicked select_) + (selectColumns (commentSelectColumns select_) . applyQueryModifiers where_ orderBy_ limit_ offset_) + findUnique CommentUniqueQuery {where_, select_} = do + let w = commentUniqueWhere where_ + rows <- + Ops.findManyWith + (parseCommentPicked select_) + (selectColumns (commentSelectColumns select_) . matching w) + pure (fromUniqueRows rows) + findUniqueOrFail q = uniqueOrFail <$> findUnique q + findFirst CommentQuery {select_, where_, orderBy_, limit_, offset_} = + Ops.findFirstWith + (parseCommentPicked select_) + (selectColumns (commentSelectColumns select_) . applyQueryModifiers where_ orderBy_ limit_ offset_) + findFirstOrFail q = do + result <- findFirst q + pure $ requireFound result (RecordNotFound "No record found matching query") + +count :: CommentQuery include select -> Db Int +count CommentQuery {where_, orderBy_, limit_, offset_} = + Ops.count @CommentTable (applyQueryModifiers where_ orderBy_ limit_ offset_) + +delete :: CommentUnique -> Db (Either ORMError Int) +delete key = + Delete.deleteMany @CommentTable (commentUniqueWhere key) + +deleteMany :: Where CommentTable -> Db (Either ORMError Int) +deleteMany = Delete.deleteMany @CommentTable diff --git a/test/Schema/Client/Editor.hs b/test/Schema/Client/Editor.hs new file mode 100644 --- /dev/null +++ b/test/Schema/Client/Editor.hs @@ -0,0 +1,618 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NoFieldSelectors #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +{- | Generated Client. Do not edit. + +Nested writes live on 'create' / 'update'. + create-time relation fields are [CreateChild | ConnectChild unique] + update-time relation fields are Maybe Update (replaceWith, create, connect, delete, update, upsert; + disconnect when the child foreign key is nullable) +-} +module Schema.Client.Editor + ( findMany, + findUnique, + findUniqueOrFail, + findFirst, + findFirstOrFail, + count, + create, + createMany, + update, + updateMany, + upsert, + delete, + deleteMany, + EditorCreateScalars, + EditorUpdateScalars, + ArticleNestedCreate (..), + ArticleNestedUpsert (..), + WrittenPostsUpdate (..), + emptyWrittenPostsUpdate, + EditedPostsUpdate (..), + emptyEditedPostsUpdate, + EditorQuery (..), + EditorUnique (..), + EditorUniqueKey (..), + EditorUniqueQuery (..), + emptyQuery, + uniqueQuery, + editorUniqueWhere, + OmitSelect (..), + Picked (..), + EditorCreate (..), + EditorRow (..), + EditorSelect (..), + EditorPicked (..), + editorSelect, + EditorUpdate (..), + EditorTable, + editorId + ) +where + +import Data.Maybe (isJust) +import Data.Text (Text) +import Data.UUID (UUID) +import Poppy.Internal.Generated + ( Db, + transactionEither, + fieldColumn, + toField, + ORMError (..), + fromUniqueRows, + requireFound, + uniqueOrFail, + OrderBy, + applyQueryModifiers, + matching, + selectColumns, + OmitSelect (..), + Picked (..), + prepareIncludeRootQuery, + Where, + and_, + eq + ) +import qualified Poppy.Internal.Generated as Delete + ( deleteMany, + deleteWhere, + whereDelete, + emptyDelete + ) +import qualified Poppy.Internal.Generated as Insert + ( insert, + insertMany, + upsert + ) +import qualified Poppy.Internal.Generated as Ops + ( findMany, + findManyWith, + findFirst, + findFirstWith, + count + ) +import qualified Poppy.Internal.Generated as Update + ( updateWhere, + updateMany + ) + +import Schema.Editor (EditorRow (..), EditorSelect (..), EditorPicked (..), editorSelect, editorSelectColumns, parseEditorPicked, EditorTable, editorId) +import qualified Schema.Editor as EditorSchema (EditorCreate (..), EditorUpdate (..)) + +import Schema.Include.Editor (LoadEditor (..), EditorInclude (..), EditorRead, toEditorWithPicked) +import Schema.Article (ArticleRow (..), ArticleTable, articleId, articleAuthorId, ArticleCreate (..), ArticleUpdate (..)) +import qualified Schema.Client.Article as Article (ArticleUnique (..), articleUniqueWhere) + +data EditorUnique + = ById UUID + deriving (Eq, Show) + +data EditorUniqueKey + = OnId + deriving (Eq, Show) + +editorUniqueWhere :: EditorUnique -> Where EditorTable +editorUniqueWhere = \case + ById v1 -> eq editorId v1 + +editorConflictCols :: EditorUniqueKey -> [Text] +editorConflictCols = \case + OnId -> ["id"] + +data ArticleNestedCreate + = CreateArticle + { id :: Maybe UUID, title :: Text + } + | ConnectArticle Article.ArticleUnique + deriving (Show, Eq) +data ArticleNestedUpsert = ArticleNestedUpsert + { where_ :: Article.ArticleUnique + , create :: ArticleNestedCreate + , update :: ArticleUpdate + } + deriving (Show, Eq) +data WrittenPostsUpdate = WrittenPostsUpdate + { replaceWith :: Maybe [ArticleNestedCreate] + , create :: [ArticleNestedCreate] + , createMany :: [ArticleNestedCreate] + , connect :: [Article.ArticleUnique] + , delete :: [Article.ArticleUnique] + , update :: [(Article.ArticleUnique, ArticleUpdate)] + , upsert :: [ArticleNestedUpsert] + } + deriving (Show, Eq) + +emptyWrittenPostsUpdate :: WrittenPostsUpdate +emptyWrittenPostsUpdate = + WrittenPostsUpdate + { replaceWith = Nothing + , create = [] + , createMany = [] + , connect = [] + , delete = [] + , update = [] + , upsert = [] + } +data EditedPostsUpdate = EditedPostsUpdate + { replaceWith :: Maybe [ArticleNestedCreate] + , create :: [ArticleNestedCreate] + , createMany :: [ArticleNestedCreate] + , connect :: [Article.ArticleUnique] + , delete :: [Article.ArticleUnique] + , update :: [(Article.ArticleUnique, ArticleUpdate)] + , upsert :: [ArticleNestedUpsert] + } + deriving (Show, Eq) + +emptyEditedPostsUpdate :: EditedPostsUpdate +emptyEditedPostsUpdate = + EditedPostsUpdate + { replaceWith = Nothing + , create = [] + , createMany = [] + , connect = [] + , delete = [] + , update = [] + , upsert = [] + } +data EditorCreate = EditorCreate + { id :: Maybe UUID, + name :: Text, + writtenPosts :: [ArticleNestedCreate], + editedPosts :: [ArticleNestedCreate] + } + deriving (Show, Eq) + +type EditorCreateScalars = EditorSchema.EditorCreate + +toEditorCreateScalars :: EditorCreate -> EditorCreateScalars +toEditorCreateScalars input = + EditorSchema.EditorCreate + { id = input.id, + name = input.name + } +data EditorUpdate = EditorUpdate + { name :: Maybe Text, + writtenPosts :: Maybe WrittenPostsUpdate, + editedPosts :: Maybe EditedPostsUpdate + } + deriving (Show, Eq) + +type EditorUpdateScalars = EditorSchema.EditorUpdate + +toEditorUpdateScalars :: EditorUpdate -> EditorUpdateScalars +toEditorUpdateScalars input = + EditorSchema.EditorUpdate + { name = input.name + } + +create :: EditorCreate -> Db (Either ORMError EditorRow) +create input = + if hasEditorNestedCreate input + then transactionEither (createWithNested input) + else Insert.insert @EditorTable @EditorRow (toEditorCreateScalars input) + +hasEditorNestedCreate :: EditorCreate -> Bool +hasEditorNestedCreate input = + not (null input.writtenPosts) || not (null input.editedPosts) + +createWithNested :: EditorCreate -> Db (Either ORMError EditorRow) +createWithNested input = do + rootResult <- Insert.insert @EditorTable @EditorRow (toEditorCreateScalars input) + case rootResult of + Left err -> pure (Left err) + Right row -> do + nestedResult <- + sequenceNested + [ applyWrittenPostsCreate row.id input.writtenPosts + , applyEditedPostsCreate row.id input.editedPosts + ] + case nestedResult of + Left err -> pure (Left err) + Right () -> pure (Right row) + +createMany :: [EditorCreateScalars] -> Db (Either ORMError Int) +createMany = Insert.insertMany @EditorTable + +update :: EditorUnique -> EditorUpdate -> Db (Either ORMError EditorRow) +update key input = + if hasEditorNestedUpdate input + then transactionEither (updateWithNested key input) + else Update.updateWhere @EditorTable @EditorRow (editorUniqueWhere key) (toEditorUpdateScalars input) + +hasEditorNestedUpdate :: EditorUpdate -> Bool +hasEditorNestedUpdate input = + isJust input.writtenPosts || isJust input.editedPosts + +updateWithNested :: EditorUnique -> EditorUpdate -> Db (Either ORMError EditorRow) +updateWithNested key input = do + updateResult <- Update.updateWhere @EditorTable @EditorRow (editorUniqueWhere key) (toEditorUpdateScalars input) + case updateResult of + Left err -> pure (Left err) + Right row -> do + nestedResult <- + sequenceNested + [ maybe (pure (Right ())) (applyWrittenPostsUpdate row.id) input.writtenPosts + , maybe (pure (Right ())) (applyEditedPostsUpdate row.id) input.editedPosts + ] + case nestedResult of + Left err -> pure (Left err) + Right () -> pure (Right row) + +updateMany :: Where EditorTable -> EditorUpdateScalars -> Db (Either ORMError Int) +updateMany = Update.updateMany @EditorTable + +upsert :: EditorUniqueKey -> EditorCreateScalars -> EditorUpdateScalars -> Db (Either ORMError EditorRow) +upsert key createInput updateInput = + Insert.upsert @EditorTable @EditorRow (editorConflictCols key) createInput updateInput + +sequenceNested :: [Db (Either ORMError ())] -> Db (Either ORMError ()) +sequenceNested [] = pure (Right ()) +sequenceNested (action : rest) = do + result <- action + case result of + Left err -> pure (Left err) + Right () -> sequenceNested rest +applyWrittenPostsCreate :: UUID -> [ArticleNestedCreate] -> Db (Either ORMError ()) +applyWrittenPostsCreate = insertWrittenPosts +applyWrittenPostsUpdate :: UUID -> WrittenPostsUpdate -> Db (Either ORMError ()) +applyWrittenPostsUpdate parentId ops = do + replaced <- case ops.replaceWith of + Nothing -> pure (Right ()) + Just items -> replaceWrittenPosts parentId items + case replaced of + Left err -> pure (Left err) + Right () -> + sequenceNested + [ deleteWrittenPosts parentId ops.delete + , updateWrittenPostsRows parentId ops.update + , upsertWrittenPosts parentId ops.upsert + , insertWrittenPosts parentId ops.create + , insertWrittenPosts parentId ops.createMany + , connectWrittenPosts parentId ops.connect + ] +replaceWrittenPosts :: UUID -> [ArticleNestedCreate] -> Db (Either ORMError ()) +replaceWrittenPosts parentId items = do + result <- + Delete.deleteWhere $ + Delete.whereDelete (fieldColumn articleAuthorId <> " = ?") [toField parentId] (Delete.emptyDelete @ArticleTable) + case result of + Left err -> pure (Left err) + Right _ -> insertWrittenPosts parentId items +insertWrittenPosts :: UUID -> [ArticleNestedCreate] -> Db (Either ORMError ()) +insertWrittenPosts parentId = go + where + go [] = pure (Right ()) + go (nested : rest) = do + result <- case nested of + ConnectArticle key -> connectWrittenPosts parentId [key] + CreateArticle {id, title} -> do + inserted <- Insert.insert @ArticleTable @ArticleRow ArticleCreate + { id = id, + title = title, + authorId = parentId + } + pure $ case inserted of + Left err -> Left err + Right _ -> Right () + case result of + Left err -> pure (Left err) + Right () -> go rest +deleteWrittenPosts :: UUID -> [Article.ArticleUnique] -> Db (Either ORMError ()) +deleteWrittenPosts _ [] = pure (Right ()) +deleteWrittenPosts parentId keys = sequenceNested (map deleteOne keys) + where + deleteOne key = do + result <- Delete.deleteMany @ArticleTable + (Article.articleUniqueWhere key `and_` eq articleAuthorId parentId) + pure $ case result of + Left err -> Left err + Right _ -> Right () +updateWrittenPostsRows :: UUID -> [(Article.ArticleUnique, ArticleUpdate)] -> Db (Either ORMError ()) +updateWrittenPostsRows parentId = go + where + go [] = pure (Right ()) + go ((key, nested) : rest) = do + let patched = ArticleUpdate { authorId = Nothing, title = nested.title } + result <- + Update.updateWhere @ArticleTable @ArticleRow + (Article.articleUniqueWhere key `and_` eq articleAuthorId parentId) + patched + case result of + Left err -> pure (Left err) + Right _ -> go rest +upsertWrittenPosts :: UUID -> [ArticleNestedUpsert] -> Db (Either ORMError ()) +upsertWrittenPosts parentId = go + where + go [] = pure (Right ()) + go (item : rest) = do + existing <- Ops.findMany @ArticleTable @ArticleRow (matching (Article.articleUniqueWhere item.where_)) + result <- case fromUniqueRows existing of + Left err -> pure (Left err) + Right Nothing -> insertWrittenPosts parentId [item.create] + Right (Just row) -> + if row.authorId == parentId + then do + let patched = ArticleUpdate { authorId = Nothing, title = item.update.title } + updated <- + Update.updateWhere @ArticleTable @ArticleRow + (Article.articleUniqueWhere item.where_ `and_` eq articleAuthorId parentId) + patched + pure $ case updated of + Left err -> Left err + Right _ -> Right () + else pure (Left (UniqueViolation "nested upsert would reparent a row owned by another parent")) + case result of + Left err -> pure (Left err) + Right () -> go rest +connectWrittenPosts :: UUID -> [Article.ArticleUnique] -> Db (Either ORMError ()) +connectWrittenPosts _ [] = pure (Right ()) +connectWrittenPosts parentId keys = sequenceNested (map connectOne keys) + where + connectOne key = do + result <- + Update.updateWhere @ArticleTable @ArticleRow + (Article.articleUniqueWhere key) + (ArticleUpdate + { authorId = Just parentId, + title = Nothing + }) + pure $ case result of + Left err -> Left err + Right _ -> Right () +applyEditedPostsCreate :: UUID -> [ArticleNestedCreate] -> Db (Either ORMError ()) +applyEditedPostsCreate = insertEditedPosts +applyEditedPostsUpdate :: UUID -> EditedPostsUpdate -> Db (Either ORMError ()) +applyEditedPostsUpdate parentId ops = do + replaced <- case ops.replaceWith of + Nothing -> pure (Right ()) + Just items -> replaceEditedPosts parentId items + case replaced of + Left err -> pure (Left err) + Right () -> + sequenceNested + [ deleteEditedPosts parentId ops.delete + , updateEditedPostsRows parentId ops.update + , upsertEditedPosts parentId ops.upsert + , insertEditedPosts parentId ops.create + , insertEditedPosts parentId ops.createMany + , connectEditedPosts parentId ops.connect + ] +replaceEditedPosts :: UUID -> [ArticleNestedCreate] -> Db (Either ORMError ()) +replaceEditedPosts parentId items = do + result <- + Delete.deleteWhere $ + Delete.whereDelete (fieldColumn articleAuthorId <> " = ?") [toField parentId] (Delete.emptyDelete @ArticleTable) + case result of + Left err -> pure (Left err) + Right _ -> insertEditedPosts parentId items +insertEditedPosts :: UUID -> [ArticleNestedCreate] -> Db (Either ORMError ()) +insertEditedPosts parentId = go + where + go [] = pure (Right ()) + go (nested : rest) = do + result <- case nested of + ConnectArticle key -> connectEditedPosts parentId [key] + CreateArticle {id, title} -> do + inserted <- Insert.insert @ArticleTable @ArticleRow ArticleCreate + { id = id, + title = title, + authorId = parentId + } + pure $ case inserted of + Left err -> Left err + Right _ -> Right () + case result of + Left err -> pure (Left err) + Right () -> go rest +deleteEditedPosts :: UUID -> [Article.ArticleUnique] -> Db (Either ORMError ()) +deleteEditedPosts _ [] = pure (Right ()) +deleteEditedPosts parentId keys = sequenceNested (map deleteOne keys) + where + deleteOne key = do + result <- Delete.deleteMany @ArticleTable + (Article.articleUniqueWhere key `and_` eq articleAuthorId parentId) + pure $ case result of + Left err -> Left err + Right _ -> Right () +updateEditedPostsRows :: UUID -> [(Article.ArticleUnique, ArticleUpdate)] -> Db (Either ORMError ()) +updateEditedPostsRows parentId = go + where + go [] = pure (Right ()) + go ((key, nested) : rest) = do + let patched = ArticleUpdate { authorId = Nothing, title = nested.title } + result <- + Update.updateWhere @ArticleTable @ArticleRow + (Article.articleUniqueWhere key `and_` eq articleAuthorId parentId) + patched + case result of + Left err -> pure (Left err) + Right _ -> go rest +upsertEditedPosts :: UUID -> [ArticleNestedUpsert] -> Db (Either ORMError ()) +upsertEditedPosts parentId = go + where + go [] = pure (Right ()) + go (item : rest) = do + existing <- Ops.findMany @ArticleTable @ArticleRow (matching (Article.articleUniqueWhere item.where_)) + result <- case fromUniqueRows existing of + Left err -> pure (Left err) + Right Nothing -> insertEditedPosts parentId [item.create] + Right (Just row) -> + if row.authorId == parentId + then do + let patched = ArticleUpdate { authorId = Nothing, title = item.update.title } + updated <- + Update.updateWhere @ArticleTable @ArticleRow + (Article.articleUniqueWhere item.where_ `and_` eq articleAuthorId parentId) + patched + pure $ case updated of + Left err -> Left err + Right _ -> Right () + else pure (Left (UniqueViolation "nested upsert would reparent a row owned by another parent")) + case result of + Left err -> pure (Left err) + Right () -> go rest +connectEditedPosts :: UUID -> [Article.ArticleUnique] -> Db (Either ORMError ()) +connectEditedPosts _ [] = pure (Right ()) +connectEditedPosts parentId keys = sequenceNested (map connectOne keys) + where + connectOne key = do + result <- + Update.updateWhere @ArticleTable @ArticleRow + (Article.articleUniqueWhere key) + (ArticleUpdate + { authorId = Just parentId, + title = Nothing + }) + pure $ case result of + Left err -> Left err + Right _ -> Right () + +data EditorQuery include select = EditorQuery + { include_ :: include + , select_ :: select + , where_ :: Maybe (Where EditorTable) + , orderBy_ :: [OrderBy EditorTable] + , limit_ :: Maybe Int + , offset_ :: Maybe Int + } + +data EditorUniqueQuery include select = EditorUniqueQuery + { include_ :: include + , select_ :: select + , where_ :: EditorUnique + } + +emptyQuery :: EditorQuery () OmitSelect +emptyQuery = + EditorQuery {include_ = (), select_ = OmitSelect, where_ = Nothing, orderBy_ = [], limit_ = Nothing, offset_ = Nothing} + +uniqueQuery :: EditorUnique -> EditorUniqueQuery () OmitSelect +uniqueQuery key = + EditorUniqueQuery {include_ = (), select_ = OmitSelect, where_ = key} + +class ReadEditor include select where + findMany :: EditorQuery include select -> Db [EditorRead include select] + findUnique :: EditorUniqueQuery include select -> Db (Either ORMError (Maybe (EditorRead include select))) + findUniqueOrFail :: EditorUniqueQuery include select -> Db (Either ORMError (EditorRead include select)) + findFirst :: EditorQuery include select -> Db (Maybe (EditorRead include select)) + findFirstOrFail :: EditorQuery include select -> Db (Either ORMError (EditorRead include select)) + +instance (LoadEditor writtenPosts editedPosts) => ReadEditor (EditorInclude writtenPosts editedPosts) OmitSelect where + findMany EditorQuery {include_, where_, orderBy_, limit_, offset_} = do + roots <- Ops.findMany @EditorTable @EditorRow (prepareIncludeRootQuery @EditorTable (applyQueryModifiers where_ orderBy_ limit_ offset_)) + loadEditor include_ roots + findUnique EditorUniqueQuery {where_, include_} = do + let w = editorUniqueWhere where_ + roots <- Ops.findMany @EditorTable @EditorRow (prepareIncludeRootQuery @EditorTable (matching w)) + rows <- loadEditor include_ roots + pure (fromUniqueRows rows) + findUniqueOrFail q = uniqueOrFail <$> findUnique q + findFirst EditorQuery {include_, where_, orderBy_, offset_} = do + roots <- Ops.findMany @EditorTable @EditorRow (prepareIncludeRootQuery @EditorTable (applyQueryModifiers where_ orderBy_ (Just 1) offset_)) + loaded <- loadEditor include_ roots + pure $ case loaded of + [] -> Nothing + (row : _) -> Just row + findFirstOrFail q = do + result <- findFirst q + pure $ requireFound result (RecordNotFound "No record found matching query") + +instance ReadEditor () OmitSelect where + findMany EditorQuery {where_, orderBy_, limit_, offset_} = + Ops.findMany @EditorTable @EditorRow (applyQueryModifiers where_ orderBy_ limit_ offset_) + findUnique EditorUniqueQuery {where_} = do + let w = editorUniqueWhere where_ + rows <- Ops.findMany @EditorTable @EditorRow (matching w) + pure (fromUniqueRows rows) + findUniqueOrFail q = uniqueOrFail <$> findUnique q + findFirst EditorQuery {where_, orderBy_, limit_, offset_} = + Ops.findFirst @EditorTable @EditorRow (applyQueryModifiers where_ orderBy_ limit_ offset_) + findFirstOrFail q = do + result <- findFirst q + pure $ requireFound result (RecordNotFound "No record found matching query") + +instance (LoadEditor writtenPosts editedPosts) => ReadEditor (EditorInclude writtenPosts editedPosts) EditorSelect where + findMany EditorQuery {include_, select_, where_, orderBy_, limit_, offset_} = do + roots <- Ops.findMany @EditorTable @EditorRow (prepareIncludeRootQuery @EditorTable (applyQueryModifiers where_ orderBy_ limit_ offset_)) + loaded <- loadEditor include_ roots + pure $ map (toEditorWithPicked select_) loaded + findUnique EditorUniqueQuery {where_, include_, select_} = do + let w = editorUniqueWhere where_ + roots <- Ops.findMany @EditorTable @EditorRow (prepareIncludeRootQuery @EditorTable (matching w)) + loaded <- loadEditor include_ roots + let rows = map (toEditorWithPicked select_) loaded + pure (fromUniqueRows rows) + findUniqueOrFail q = uniqueOrFail <$> findUnique q + findFirst EditorQuery {select_, include_, where_, orderBy_, offset_} = do + roots <- Ops.findMany @EditorTable @EditorRow (prepareIncludeRootQuery @EditorTable (applyQueryModifiers where_ orderBy_ (Just 1) offset_)) + loaded <- loadEditor include_ roots + pure $ case loaded of + [] -> Nothing + (row : _) -> Just (toEditorWithPicked select_ row) + findFirstOrFail q = do + result <- findFirst q + pure $ requireFound result (RecordNotFound "No record found matching query") + +instance ReadEditor () EditorSelect where + findMany EditorQuery {select_, where_, orderBy_, limit_, offset_} = + Ops.findManyWith + (parseEditorPicked select_) + (selectColumns (editorSelectColumns select_) . applyQueryModifiers where_ orderBy_ limit_ offset_) + findUnique EditorUniqueQuery {where_, select_} = do + let w = editorUniqueWhere where_ + rows <- + Ops.findManyWith + (parseEditorPicked select_) + (selectColumns (editorSelectColumns select_) . matching w) + pure (fromUniqueRows rows) + findUniqueOrFail q = uniqueOrFail <$> findUnique q + findFirst EditorQuery {select_, where_, orderBy_, limit_, offset_} = + Ops.findFirstWith + (parseEditorPicked select_) + (selectColumns (editorSelectColumns select_) . applyQueryModifiers where_ orderBy_ limit_ offset_) + findFirstOrFail q = do + result <- findFirst q + pure $ requireFound result (RecordNotFound "No record found matching query") + +count :: EditorQuery include select -> Db Int +count EditorQuery {where_, orderBy_, limit_, offset_} = + Ops.count @EditorTable (applyQueryModifiers where_ orderBy_ limit_ offset_) + +delete :: EditorUnique -> Db (Either ORMError Int) +delete key = + Delete.deleteMany @EditorTable (editorUniqueWhere key) + +deleteMany :: Where EditorTable -> Db (Either ORMError Int) +deleteMany = Delete.deleteMany @EditorTable diff --git a/test/Schema/Client/Post.hs b/test/Schema/Client/Post.hs new file mode 100644 --- /dev/null +++ b/test/Schema/Client/Post.hs @@ -0,0 +1,244 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NoFieldSelectors #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +{- | Generated Client. Do not edit. +-} +module Schema.Client.Post + ( findMany, + findUnique, + findUniqueOrFail, + findFirst, + findFirstOrFail, + count, + create, + createMany, + update, + updateMany, + upsert, + delete, + deleteMany, + PostQuery (..), + PostUnique (..), + PostUniqueKey (..), + PostUniqueQuery (..), + emptyQuery, + uniqueQuery, + postUniqueWhere, + OmitSelect (..), + Picked (..), + PostCreate (..), + PostRow (..), + PostSelect (..), + PostPicked (..), + postSelect, + PostUpdate (..), + PostTable, + postId + ) +where + +import Data.UUID (UUID) +import Poppy.Internal.Generated + ( Db, + ORMError (..), + fromUniqueRows, + requireFound, + uniqueOrFail, + OrderBy, + applyQueryModifiers, + matching, + selectColumns, + OmitSelect (..), + Picked (..), + prepareIncludeRootQuery, + Where, + eq + ) +import qualified Poppy.Internal.Generated as Delete + ( deleteMany, + deleteWhere, + whereDelete, + emptyDelete + ) +import qualified Poppy.Internal.Generated as Insert + ( insert, + insertMany, + upsert + ) +import qualified Poppy.Internal.Generated as Ops + ( findMany, + findManyWith, + findFirst, + findFirstWith, + count + ) +import qualified Poppy.Internal.Generated as Update + ( updateWhere, + updateMany + ) + +import Schema.Post (PostCreate (..), PostUpdate (..), PostRow (..), PostSelect (..), PostPicked (..), postSelect, postSelectColumns, parsePostPicked, PostTable, postId) +import Schema.Include.Post (LoadPost (..), PostInclude (..), PostRead, toPostWithPicked) +import Data.Text (Text) + +data PostUnique + = ById UUID + deriving (Eq, Show) + +data PostUniqueKey + = OnId + deriving (Eq, Show) + +postUniqueWhere :: PostUnique -> Where PostTable +postUniqueWhere = \case + ById v1 -> eq postId v1 + +postConflictCols :: PostUniqueKey -> [Text] +postConflictCols = \case + OnId -> ["id"] + +create :: PostCreate -> Db (Either ORMError PostRow) +create = Insert.insert @PostTable @PostRow + +createMany :: [PostCreate] -> Db (Either ORMError Int) +createMany = Insert.insertMany @PostTable + +update :: PostUnique -> PostUpdate -> Db (Either ORMError PostRow) +update key input = + Update.updateWhere @PostTable @PostRow (postUniqueWhere key) input + +updateMany :: Where PostTable -> PostUpdate -> Db (Either ORMError Int) +updateMany = Update.updateMany @PostTable + +upsert :: PostUniqueKey -> PostCreate -> PostUpdate -> Db (Either ORMError PostRow) +upsert key createInput updateInput = + Insert.upsert @PostTable @PostRow (postConflictCols key) createInput updateInput + +data PostQuery include select = PostQuery + { include_ :: include + , select_ :: select + , where_ :: Maybe (Where PostTable) + , orderBy_ :: [OrderBy PostTable] + , limit_ :: Maybe Int + , offset_ :: Maybe Int + } + +data PostUniqueQuery include select = PostUniqueQuery + { include_ :: include + , select_ :: select + , where_ :: PostUnique + } + +emptyQuery :: PostQuery () OmitSelect +emptyQuery = + PostQuery {include_ = (), select_ = OmitSelect, where_ = Nothing, orderBy_ = [], limit_ = Nothing, offset_ = Nothing} + +uniqueQuery :: PostUnique -> PostUniqueQuery () OmitSelect +uniqueQuery key = + PostUniqueQuery {include_ = (), select_ = OmitSelect, where_ = key} + +class ReadPost include select where + findMany :: PostQuery include select -> Db [PostRead include select] + findUnique :: PostUniqueQuery include select -> Db (Either ORMError (Maybe (PostRead include select))) + findUniqueOrFail :: PostUniqueQuery include select -> Db (Either ORMError (PostRead include select)) + findFirst :: PostQuery include select -> Db (Maybe (PostRead include select)) + findFirstOrFail :: PostQuery include select -> Db (Either ORMError (PostRead include select)) + +instance (LoadPost author) => ReadPost (PostInclude author) OmitSelect where + findMany PostQuery {include_, where_, orderBy_, limit_, offset_} = do + roots <- Ops.findMany @PostTable @PostRow (prepareIncludeRootQuery @PostTable (applyQueryModifiers where_ orderBy_ limit_ offset_)) + loadPost include_ roots + findUnique PostUniqueQuery {where_, include_} = do + let w = postUniqueWhere where_ + roots <- Ops.findMany @PostTable @PostRow (prepareIncludeRootQuery @PostTable (matching w)) + rows <- loadPost include_ roots + pure (fromUniqueRows rows) + findUniqueOrFail q = uniqueOrFail <$> findUnique q + findFirst PostQuery {include_, where_, orderBy_, offset_} = do + roots <- Ops.findMany @PostTable @PostRow (prepareIncludeRootQuery @PostTable (applyQueryModifiers where_ orderBy_ (Just 1) offset_)) + loaded <- loadPost include_ roots + pure $ case loaded of + [] -> Nothing + (row : _) -> Just row + findFirstOrFail q = do + result <- findFirst q + pure $ requireFound result (RecordNotFound "No record found matching query") + +instance ReadPost () OmitSelect where + findMany PostQuery {where_, orderBy_, limit_, offset_} = + Ops.findMany @PostTable @PostRow (applyQueryModifiers where_ orderBy_ limit_ offset_) + findUnique PostUniqueQuery {where_} = do + let w = postUniqueWhere where_ + rows <- Ops.findMany @PostTable @PostRow (matching w) + pure (fromUniqueRows rows) + findUniqueOrFail q = uniqueOrFail <$> findUnique q + findFirst PostQuery {where_, orderBy_, limit_, offset_} = + Ops.findFirst @PostTable @PostRow (applyQueryModifiers where_ orderBy_ limit_ offset_) + findFirstOrFail q = do + result <- findFirst q + pure $ requireFound result (RecordNotFound "No record found matching query") + +instance (LoadPost author) => ReadPost (PostInclude author) PostSelect where + findMany PostQuery {include_, select_, where_, orderBy_, limit_, offset_} = do + roots <- Ops.findMany @PostTable @PostRow (prepareIncludeRootQuery @PostTable (applyQueryModifiers where_ orderBy_ limit_ offset_)) + loaded <- loadPost include_ roots + pure $ map (toPostWithPicked select_) loaded + findUnique PostUniqueQuery {where_, include_, select_} = do + let w = postUniqueWhere where_ + roots <- Ops.findMany @PostTable @PostRow (prepareIncludeRootQuery @PostTable (matching w)) + loaded <- loadPost include_ roots + let rows = map (toPostWithPicked select_) loaded + pure (fromUniqueRows rows) + findUniqueOrFail q = uniqueOrFail <$> findUnique q + findFirst PostQuery {select_, include_, where_, orderBy_, offset_} = do + roots <- Ops.findMany @PostTable @PostRow (prepareIncludeRootQuery @PostTable (applyQueryModifiers where_ orderBy_ (Just 1) offset_)) + loaded <- loadPost include_ roots + pure $ case loaded of + [] -> Nothing + (row : _) -> Just (toPostWithPicked select_ row) + findFirstOrFail q = do + result <- findFirst q + pure $ requireFound result (RecordNotFound "No record found matching query") + +instance ReadPost () PostSelect where + findMany PostQuery {select_, where_, orderBy_, limit_, offset_} = + Ops.findManyWith + (parsePostPicked select_) + (selectColumns (postSelectColumns select_) . applyQueryModifiers where_ orderBy_ limit_ offset_) + findUnique PostUniqueQuery {where_, select_} = do + let w = postUniqueWhere where_ + rows <- + Ops.findManyWith + (parsePostPicked select_) + (selectColumns (postSelectColumns select_) . matching w) + pure (fromUniqueRows rows) + findUniqueOrFail q = uniqueOrFail <$> findUnique q + findFirst PostQuery {select_, where_, orderBy_, limit_, offset_} = + Ops.findFirstWith + (parsePostPicked select_) + (selectColumns (postSelectColumns select_) . applyQueryModifiers where_ orderBy_ limit_ offset_) + findFirstOrFail q = do + result <- findFirst q + pure $ requireFound result (RecordNotFound "No record found matching query") + +count :: PostQuery include select -> Db Int +count PostQuery {where_, orderBy_, limit_, offset_} = + Ops.count @PostTable (applyQueryModifiers where_ orderBy_ limit_ offset_) + +delete :: PostUnique -> Db (Either ORMError Int) +delete key = + Delete.deleteMany @PostTable (postUniqueWhere key) + +deleteMany :: Where PostTable -> Db (Either ORMError Int) +deleteMany = Delete.deleteMany @PostTable diff --git a/test/Schema/Client/Section.hs b/test/Schema/Client/Section.hs new file mode 100644 --- /dev/null +++ b/test/Schema/Client/Section.hs @@ -0,0 +1,213 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +module Schema.Client.Section + ( create, + createMany, + update, + updateMany, + upsert, + findMany, + findUnique, + findUniqueOrFail, + findFirst, + findFirstOrFail, + count, + delete, + deleteMany, + SectionCreate (..), + SectionRow (..), + SectionSelect (..), + SectionPicked (..), + sectionSelect, + OmitSelect (..), + Picked (..), + ResolveSelect, + SectionUpdate (..), + SectionTable, + SectionQuery (..), + SectionUnique (..), + SectionUniqueKey (..), + SectionUniqueQuery (..), + emptyQuery, + uniqueQuery, + sectionUniqueWhere, + sectionId + ) + +where + +import Data.Text (Text) +import Data.UUID (UUID) +import Poppy.Internal.Generated + ( Db, + ORMError (..), + fromUniqueRows, + requireFound, + uniqueOrFail, + OrderBy, + QueryBuilder, + applyQueryModifiers, + matching, + selectColumns, + OmitSelect (..), + Picked (..), + Where, + eq + ) +import qualified Poppy.Internal.Generated as Delete + ( deleteMany + ) +import qualified Poppy.Internal.Generated as Insert + ( insert, + insertMany, + upsert + ) +import qualified Poppy.Internal.Generated as Ops + ( findMany, + findManyWith, + findFirst, + findFirstWith, + count + ) +import qualified Poppy.Internal.Generated as Update + ( updateWhere, + updateMany + ) + +import Schema.Section (SectionCreate (..), SectionRow (..), SectionSelect (..), SectionPicked (..), sectionSelect, sectionSelectColumns, parseSectionPicked, SectionTable, SectionUpdate (..), sectionId) + +data SectionUnique + = ById UUID + deriving (Eq, Show) + +data SectionUniqueKey + = OnId + deriving (Eq, Show) + +sectionUniqueWhere :: SectionUnique -> Where SectionTable +sectionUniqueWhere = \case + ById v1 -> eq sectionId v1 + +sectionConflictCols :: SectionUniqueKey -> [Text] +sectionConflictCols = \case + OnId -> ["id"] + + +create :: SectionCreate -> Db (Either ORMError SectionRow) +create = Insert.insert @SectionTable @SectionRow + + +createMany :: [SectionCreate] -> Db (Either ORMError Int) +createMany = Insert.insertMany @SectionTable + + +update :: SectionUnique -> SectionUpdate -> Db (Either ORMError SectionRow) +update key input = + Update.updateWhere @SectionTable @SectionRow (sectionUniqueWhere key) input + + +updateMany :: Where SectionTable -> SectionUpdate -> Db (Either ORMError Int) +updateMany = Update.updateMany @SectionTable + + +upsert :: SectionUniqueKey -> SectionCreate -> SectionUpdate -> Db (Either ORMError SectionRow) +upsert key createInput updateInput = + Insert.upsert @SectionTable @SectionRow (sectionConflictCols key) createInput updateInput + + +data SectionQuery select = SectionQuery + { select_ :: select + , where_ :: Maybe (Where SectionTable) + , orderBy_ :: [OrderBy SectionTable] + , limit_ :: Maybe Int + , offset_ :: Maybe Int + } + + +data SectionUniqueQuery select = SectionUniqueQuery + { select_ :: select + , where_ :: SectionUnique + } + + +emptyQuery :: SectionQuery OmitSelect +emptyQuery = + SectionQuery {select_ = OmitSelect, where_ = Nothing, orderBy_ = [], limit_ = Nothing, offset_ = Nothing} + + +uniqueQuery :: SectionUnique -> SectionUniqueQuery OmitSelect +uniqueQuery key = + SectionUniqueQuery {select_ = OmitSelect, where_ = key} + + +type family ResolveSelect select +type instance ResolveSelect OmitSelect = SectionRow +type instance ResolveSelect SectionSelect = SectionPicked + + +class ReadSection select where + findMany :: SectionQuery select -> Db [ResolveSelect select] + findUnique :: SectionUniqueQuery select -> Db (Either ORMError (Maybe (ResolveSelect select))) + findUniqueOrFail :: SectionUniqueQuery select -> Db (Either ORMError (ResolveSelect select)) + findFirst :: SectionQuery select -> Db (Maybe (ResolveSelect select)) + findFirstOrFail :: SectionQuery select -> Db (Either ORMError (ResolveSelect select)) + +instance ReadSection OmitSelect where + findMany q = + Ops.findMany @SectionTable @SectionRow (applyQuery q) + findUnique SectionUniqueQuery {where_} = do + let w = sectionUniqueWhere where_ + rows <- Ops.findMany @SectionTable @SectionRow (matching w) + pure (fromUniqueRows rows) + findUniqueOrFail q = uniqueOrFail <$> findUnique q + findFirst q = + Ops.findFirst @SectionTable @SectionRow (applyQuery q) + findFirstOrFail q = do + result <- findFirst q + pure $ requireFound result (RecordNotFound "No record found matching query") + +instance ReadSection SectionSelect where + findMany q@SectionQuery {select_} = + Ops.findManyWith + (parseSectionPicked select_) + (selectColumns (sectionSelectColumns select_) . applyQuery q) + findUnique SectionUniqueQuery {where_, select_} = do + let w = sectionUniqueWhere where_ + rows <- + Ops.findManyWith + (parseSectionPicked select_) + (selectColumns (sectionSelectColumns select_) . matching w) + pure (fromUniqueRows rows) + findUniqueOrFail q = uniqueOrFail <$> findUnique q + findFirst q@SectionQuery {select_} = + Ops.findFirstWith + (parseSectionPicked select_) + (selectColumns (sectionSelectColumns select_) . applyQuery q) + findFirstOrFail q = do + result <- findFirst q + pure $ requireFound result (RecordNotFound "No record found matching query") + +applyQuery :: SectionQuery select -> QueryBuilder SectionTable -> QueryBuilder SectionTable +applyQuery SectionQuery {where_, orderBy_, limit_, offset_} = + applyQueryModifiers where_ orderBy_ limit_ offset_ + + +count :: SectionQuery select -> Db Int +count q = Ops.count @SectionTable (applyQuery q) + + +delete :: SectionUnique -> Db (Either ORMError Int) +delete key = + Delete.deleteMany @SectionTable (sectionUniqueWhere key) + + +deleteMany :: Where SectionTable -> Db (Either ORMError Int) +deleteMany = Delete.deleteMany @SectionTable + diff --git a/test/Schema/Client/Shelf.hs b/test/Schema/Client/Shelf.hs new file mode 100644 --- /dev/null +++ b/test/Schema/Client/Shelf.hs @@ -0,0 +1,634 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NoFieldSelectors #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +{- | Generated Client. Do not edit. + +Nested writes live on 'create' / 'update'. + create-time relation fields are [CreateChild | ConnectChild unique] + update-time relation fields are Maybe Update (replaceWith, create, connect, delete, update, upsert; + disconnect when the child foreign key is nullable) +-} +module Schema.Client.Shelf + ( findMany, + findUnique, + findUniqueOrFail, + findFirst, + findFirstOrFail, + count, + create, + createMany, + update, + updateMany, + upsert, + delete, + deleteMany, + ShelfCreateScalars, + ShelfUpdateScalars, + BookNestedCreate (..), + BookNestedUpsert (..), + BooksUpdate (..), + emptyBooksUpdate, + TagNestedCreate (..), + TagNestedUpsert (..), + TagsUpdate (..), + emptyTagsUpdate, + ShelfQuery (..), + ShelfUnique (..), + ShelfUniqueKey (..), + ShelfUniqueQuery (..), + emptyQuery, + uniqueQuery, + shelfUniqueWhere, + OmitSelect (..), + Picked (..), + ShelfCreate (..), + ShelfRow (..), + ShelfSelect (..), + ShelfPicked (..), + shelfSelect, + ShelfUpdate (..), + ShelfTable, + shelfId + ) +where + +import Data.Maybe (isJust) +import Data.Text (Text) +import Data.UUID (UUID) +import Poppy.Internal.Generated + ( Db, + transactionEither, + fieldColumn, + toField, + ORMError (..), + fromUniqueRows, + requireFound, + uniqueOrFail, + OrderBy, + applyQueryModifiers, + matching, + selectColumns, + OmitSelect (..), + Picked (..), + prepareIncludeRootQuery, + Where, + and_, + eq + ) +import qualified Poppy.Internal.Generated as Delete + ( deleteMany, + deleteWhere, + whereDelete, + emptyDelete + ) +import qualified Poppy.Internal.Generated as Insert + ( insert, + insertMany, + upsert + ) +import qualified Poppy.Internal.Generated as Ops + ( findMany, + findManyWith, + findFirst, + findFirstWith, + count + ) +import qualified Poppy.Internal.Generated as Update + ( updateWhere, + updateMany + ) + +import Schema.Shelf (ShelfRow (..), ShelfSelect (..), ShelfPicked (..), shelfSelect, shelfSelectColumns, parseShelfPicked, ShelfTable, shelfId) +import qualified Schema.Shelf as ShelfSchema (ShelfCreate (..), ShelfUpdate (..)) + +import Schema.Include.Shelf (LoadShelf (..), ShelfInclude (..), ShelfRead, toShelfWithPicked) +import Schema.Book (BookRow (..), BookTable, bookId, bookShelfId, BookCreate (..), BookUpdate (..)) +import Schema.Tag (TagRow (..), TagTable, tagId, tagShelfId, TagCreate (..), TagUpdate (..)) +import qualified Schema.Client.Book as Book (BookUnique (..), bookUniqueWhere) +import qualified Schema.Client.Tag as Tag (TagUnique (..), tagUniqueWhere) + +data ShelfUnique + = ById UUID + deriving (Eq, Show) + +data ShelfUniqueKey + = OnId + deriving (Eq, Show) + +shelfUniqueWhere :: ShelfUnique -> Where ShelfTable +shelfUniqueWhere = \case + ById v1 -> eq shelfId v1 + +shelfConflictCols :: ShelfUniqueKey -> [Text] +shelfConflictCols = \case + OnId -> ["id"] + +data BookNestedCreate + = CreateBook + { id :: Maybe UUID, title :: Text + } + | ConnectBook Book.BookUnique + deriving (Show, Eq) +data TagNestedCreate + = CreateTag + { id :: Maybe UUID, label :: Text + } + | ConnectTag Tag.TagUnique + deriving (Show, Eq) +data BookNestedUpsert = BookNestedUpsert + { where_ :: Book.BookUnique + , create :: BookNestedCreate + , update :: BookUpdate + } + deriving (Show, Eq) +data TagNestedUpsert = TagNestedUpsert + { where_ :: Tag.TagUnique + , create :: TagNestedCreate + , update :: TagUpdate + } + deriving (Show, Eq) +data BooksUpdate = BooksUpdate + { replaceWith :: Maybe [BookNestedCreate] + , create :: [BookNestedCreate] + , createMany :: [BookNestedCreate] + , connect :: [Book.BookUnique] + , delete :: [Book.BookUnique] + , update :: [(Book.BookUnique, BookUpdate)] + , upsert :: [BookNestedUpsert] + } + deriving (Show, Eq) + +emptyBooksUpdate :: BooksUpdate +emptyBooksUpdate = + BooksUpdate + { replaceWith = Nothing + , create = [] + , createMany = [] + , connect = [] + , delete = [] + , update = [] + , upsert = [] + } +data TagsUpdate = TagsUpdate + { replaceWith :: Maybe [TagNestedCreate] + , create :: [TagNestedCreate] + , createMany :: [TagNestedCreate] + , connect :: [Tag.TagUnique] + , delete :: [Tag.TagUnique] + , update :: [(Tag.TagUnique, TagUpdate)] + , upsert :: [TagNestedUpsert] + } + deriving (Show, Eq) + +emptyTagsUpdate :: TagsUpdate +emptyTagsUpdate = + TagsUpdate + { replaceWith = Nothing + , create = [] + , createMany = [] + , connect = [] + , delete = [] + , update = [] + , upsert = [] + } +data ShelfCreate = ShelfCreate + { id :: Maybe UUID, + name :: Text, + books :: [BookNestedCreate], + tags :: [TagNestedCreate] + } + deriving (Show, Eq) + +type ShelfCreateScalars = ShelfSchema.ShelfCreate + +toShelfCreateScalars :: ShelfCreate -> ShelfCreateScalars +toShelfCreateScalars input = + ShelfSchema.ShelfCreate + { id = input.id, + name = input.name + } +data ShelfUpdate = ShelfUpdate + { name :: Maybe Text, + books :: Maybe BooksUpdate, + tags :: Maybe TagsUpdate + } + deriving (Show, Eq) + +type ShelfUpdateScalars = ShelfSchema.ShelfUpdate + +toShelfUpdateScalars :: ShelfUpdate -> ShelfUpdateScalars +toShelfUpdateScalars input = + ShelfSchema.ShelfUpdate + { name = input.name + } + +create :: ShelfCreate -> Db (Either ORMError ShelfRow) +create input = + if hasShelfNestedCreate input + then transactionEither (createWithNested input) + else Insert.insert @ShelfTable @ShelfRow (toShelfCreateScalars input) + +hasShelfNestedCreate :: ShelfCreate -> Bool +hasShelfNestedCreate input = + not (null input.books) || not (null input.tags) + +createWithNested :: ShelfCreate -> Db (Either ORMError ShelfRow) +createWithNested input = do + rootResult <- Insert.insert @ShelfTable @ShelfRow (toShelfCreateScalars input) + case rootResult of + Left err -> pure (Left err) + Right row -> do + nestedResult <- + sequenceNested + [ applyBooksCreate row.id input.books + , applyTagsCreate row.id input.tags + ] + case nestedResult of + Left err -> pure (Left err) + Right () -> pure (Right row) + +createMany :: [ShelfCreateScalars] -> Db (Either ORMError Int) +createMany = Insert.insertMany @ShelfTable + +update :: ShelfUnique -> ShelfUpdate -> Db (Either ORMError ShelfRow) +update key input = + if hasShelfNestedUpdate input + then transactionEither (updateWithNested key input) + else Update.updateWhere @ShelfTable @ShelfRow (shelfUniqueWhere key) (toShelfUpdateScalars input) + +hasShelfNestedUpdate :: ShelfUpdate -> Bool +hasShelfNestedUpdate input = + isJust input.books || isJust input.tags + +updateWithNested :: ShelfUnique -> ShelfUpdate -> Db (Either ORMError ShelfRow) +updateWithNested key input = do + updateResult <- Update.updateWhere @ShelfTable @ShelfRow (shelfUniqueWhere key) (toShelfUpdateScalars input) + case updateResult of + Left err -> pure (Left err) + Right row -> do + nestedResult <- + sequenceNested + [ maybe (pure (Right ())) (applyBooksUpdate row.id) input.books + , maybe (pure (Right ())) (applyTagsUpdate row.id) input.tags + ] + case nestedResult of + Left err -> pure (Left err) + Right () -> pure (Right row) + +updateMany :: Where ShelfTable -> ShelfUpdateScalars -> Db (Either ORMError Int) +updateMany = Update.updateMany @ShelfTable + +upsert :: ShelfUniqueKey -> ShelfCreateScalars -> ShelfUpdateScalars -> Db (Either ORMError ShelfRow) +upsert key createInput updateInput = + Insert.upsert @ShelfTable @ShelfRow (shelfConflictCols key) createInput updateInput + +sequenceNested :: [Db (Either ORMError ())] -> Db (Either ORMError ()) +sequenceNested [] = pure (Right ()) +sequenceNested (action : rest) = do + result <- action + case result of + Left err -> pure (Left err) + Right () -> sequenceNested rest +applyBooksCreate :: UUID -> [BookNestedCreate] -> Db (Either ORMError ()) +applyBooksCreate = insertBooks +applyBooksUpdate :: UUID -> BooksUpdate -> Db (Either ORMError ()) +applyBooksUpdate parentId ops = do + replaced <- case ops.replaceWith of + Nothing -> pure (Right ()) + Just items -> replaceBooks parentId items + case replaced of + Left err -> pure (Left err) + Right () -> + sequenceNested + [ deleteBooks parentId ops.delete + , updateBooksRows parentId ops.update + , upsertBooks parentId ops.upsert + , insertBooks parentId ops.create + , insertBooks parentId ops.createMany + , connectBooks parentId ops.connect + ] +replaceBooks :: UUID -> [BookNestedCreate] -> Db (Either ORMError ()) +replaceBooks parentId items = do + result <- + Delete.deleteWhere $ + Delete.whereDelete (fieldColumn bookShelfId <> " = ?") [toField parentId] (Delete.emptyDelete @BookTable) + case result of + Left err -> pure (Left err) + Right _ -> insertBooks parentId items +insertBooks :: UUID -> [BookNestedCreate] -> Db (Either ORMError ()) +insertBooks parentId = go + where + go [] = pure (Right ()) + go (nested : rest) = do + result <- case nested of + ConnectBook key -> connectBooks parentId [key] + CreateBook {id, title} -> do + inserted <- Insert.insert @BookTable @BookRow BookCreate + { id = id, + title = title, + shelfId = parentId + } + pure $ case inserted of + Left err -> Left err + Right _ -> Right () + case result of + Left err -> pure (Left err) + Right () -> go rest +deleteBooks :: UUID -> [Book.BookUnique] -> Db (Either ORMError ()) +deleteBooks _ [] = pure (Right ()) +deleteBooks parentId keys = sequenceNested (map deleteOne keys) + where + deleteOne key = do + result <- Delete.deleteMany @BookTable + (Book.bookUniqueWhere key `and_` eq bookShelfId parentId) + pure $ case result of + Left err -> Left err + Right _ -> Right () +updateBooksRows :: UUID -> [(Book.BookUnique, BookUpdate)] -> Db (Either ORMError ()) +updateBooksRows parentId = go + where + go [] = pure (Right ()) + go ((key, nested) : rest) = do + let patched = BookUpdate { shelfId = Nothing, title = nested.title } + result <- + Update.updateWhere @BookTable @BookRow + (Book.bookUniqueWhere key `and_` eq bookShelfId parentId) + patched + case result of + Left err -> pure (Left err) + Right _ -> go rest +upsertBooks :: UUID -> [BookNestedUpsert] -> Db (Either ORMError ()) +upsertBooks parentId = go + where + go [] = pure (Right ()) + go (item : rest) = do + existing <- Ops.findMany @BookTable @BookRow (matching (Book.bookUniqueWhere item.where_)) + result <- case fromUniqueRows existing of + Left err -> pure (Left err) + Right Nothing -> insertBooks parentId [item.create] + Right (Just row) -> + if row.shelfId == parentId + then do + let patched = BookUpdate { shelfId = Nothing, title = item.update.title } + updated <- + Update.updateWhere @BookTable @BookRow + (Book.bookUniqueWhere item.where_ `and_` eq bookShelfId parentId) + patched + pure $ case updated of + Left err -> Left err + Right _ -> Right () + else pure (Left (UniqueViolation "nested upsert would reparent a row owned by another parent")) + case result of + Left err -> pure (Left err) + Right () -> go rest +connectBooks :: UUID -> [Book.BookUnique] -> Db (Either ORMError ()) +connectBooks _ [] = pure (Right ()) +connectBooks parentId keys = sequenceNested (map connectOne keys) + where + connectOne key = do + result <- + Update.updateWhere @BookTable @BookRow + (Book.bookUniqueWhere key) + (BookUpdate + { shelfId = Just parentId, + title = Nothing + }) + pure $ case result of + Left err -> Left err + Right _ -> Right () +applyTagsCreate :: UUID -> [TagNestedCreate] -> Db (Either ORMError ()) +applyTagsCreate = insertTags +applyTagsUpdate :: UUID -> TagsUpdate -> Db (Either ORMError ()) +applyTagsUpdate parentId ops = do + replaced <- case ops.replaceWith of + Nothing -> pure (Right ()) + Just items -> replaceTags parentId items + case replaced of + Left err -> pure (Left err) + Right () -> + sequenceNested + [ deleteTags parentId ops.delete + , updateTagsRows parentId ops.update + , upsertTags parentId ops.upsert + , insertTags parentId ops.create + , insertTags parentId ops.createMany + , connectTags parentId ops.connect + ] +replaceTags :: UUID -> [TagNestedCreate] -> Db (Either ORMError ()) +replaceTags parentId items = do + result <- + Delete.deleteWhere $ + Delete.whereDelete (fieldColumn tagShelfId <> " = ?") [toField parentId] (Delete.emptyDelete @TagTable) + case result of + Left err -> pure (Left err) + Right _ -> insertTags parentId items +insertTags :: UUID -> [TagNestedCreate] -> Db (Either ORMError ()) +insertTags parentId = go + where + go [] = pure (Right ()) + go (nested : rest) = do + result <- case nested of + ConnectTag key -> connectTags parentId [key] + CreateTag {id, label} -> do + inserted <- Insert.insert @TagTable @TagRow TagCreate + { id = id, + label = label, + shelfId = parentId + } + pure $ case inserted of + Left err -> Left err + Right _ -> Right () + case result of + Left err -> pure (Left err) + Right () -> go rest +deleteTags :: UUID -> [Tag.TagUnique] -> Db (Either ORMError ()) +deleteTags _ [] = pure (Right ()) +deleteTags parentId keys = sequenceNested (map deleteOne keys) + where + deleteOne key = do + result <- Delete.deleteMany @TagTable + (Tag.tagUniqueWhere key `and_` eq tagShelfId parentId) + pure $ case result of + Left err -> Left err + Right _ -> Right () +updateTagsRows :: UUID -> [(Tag.TagUnique, TagUpdate)] -> Db (Either ORMError ()) +updateTagsRows parentId = go + where + go [] = pure (Right ()) + go ((key, nested) : rest) = do + let patched = TagUpdate { shelfId = Nothing, label = nested.label } + result <- + Update.updateWhere @TagTable @TagRow + (Tag.tagUniqueWhere key `and_` eq tagShelfId parentId) + patched + case result of + Left err -> pure (Left err) + Right _ -> go rest +upsertTags :: UUID -> [TagNestedUpsert] -> Db (Either ORMError ()) +upsertTags parentId = go + where + go [] = pure (Right ()) + go (item : rest) = do + existing <- Ops.findMany @TagTable @TagRow (matching (Tag.tagUniqueWhere item.where_)) + result <- case fromUniqueRows existing of + Left err -> pure (Left err) + Right Nothing -> insertTags parentId [item.create] + Right (Just row) -> + if row.shelfId == parentId + then do + let patched = TagUpdate { shelfId = Nothing, label = item.update.label } + updated <- + Update.updateWhere @TagTable @TagRow + (Tag.tagUniqueWhere item.where_ `and_` eq tagShelfId parentId) + patched + pure $ case updated of + Left err -> Left err + Right _ -> Right () + else pure (Left (UniqueViolation "nested upsert would reparent a row owned by another parent")) + case result of + Left err -> pure (Left err) + Right () -> go rest +connectTags :: UUID -> [Tag.TagUnique] -> Db (Either ORMError ()) +connectTags _ [] = pure (Right ()) +connectTags parentId keys = sequenceNested (map connectOne keys) + where + connectOne key = do + result <- + Update.updateWhere @TagTable @TagRow + (Tag.tagUniqueWhere key) + (TagUpdate + { shelfId = Just parentId, + label = Nothing + }) + pure $ case result of + Left err -> Left err + Right _ -> Right () + +data ShelfQuery include select = ShelfQuery + { include_ :: include + , select_ :: select + , where_ :: Maybe (Where ShelfTable) + , orderBy_ :: [OrderBy ShelfTable] + , limit_ :: Maybe Int + , offset_ :: Maybe Int + } + +data ShelfUniqueQuery include select = ShelfUniqueQuery + { include_ :: include + , select_ :: select + , where_ :: ShelfUnique + } + +emptyQuery :: ShelfQuery () OmitSelect +emptyQuery = + ShelfQuery {include_ = (), select_ = OmitSelect, where_ = Nothing, orderBy_ = [], limit_ = Nothing, offset_ = Nothing} + +uniqueQuery :: ShelfUnique -> ShelfUniqueQuery () OmitSelect +uniqueQuery key = + ShelfUniqueQuery {include_ = (), select_ = OmitSelect, where_ = key} + +class ReadShelf include select where + findMany :: ShelfQuery include select -> Db [ShelfRead include select] + findUnique :: ShelfUniqueQuery include select -> Db (Either ORMError (Maybe (ShelfRead include select))) + findUniqueOrFail :: ShelfUniqueQuery include select -> Db (Either ORMError (ShelfRead include select)) + findFirst :: ShelfQuery include select -> Db (Maybe (ShelfRead include select)) + findFirstOrFail :: ShelfQuery include select -> Db (Either ORMError (ShelfRead include select)) + +instance (LoadShelf books tags) => ReadShelf (ShelfInclude books tags) OmitSelect where + findMany ShelfQuery {include_, where_, orderBy_, limit_, offset_} = do + roots <- Ops.findMany @ShelfTable @ShelfRow (prepareIncludeRootQuery @ShelfTable (applyQueryModifiers where_ orderBy_ limit_ offset_)) + loadShelf include_ roots + findUnique ShelfUniqueQuery {where_, include_} = do + let w = shelfUniqueWhere where_ + roots <- Ops.findMany @ShelfTable @ShelfRow (prepareIncludeRootQuery @ShelfTable (matching w)) + rows <- loadShelf include_ roots + pure (fromUniqueRows rows) + findUniqueOrFail q = uniqueOrFail <$> findUnique q + findFirst ShelfQuery {include_, where_, orderBy_, offset_} = do + roots <- Ops.findMany @ShelfTable @ShelfRow (prepareIncludeRootQuery @ShelfTable (applyQueryModifiers where_ orderBy_ (Just 1) offset_)) + loaded <- loadShelf include_ roots + pure $ case loaded of + [] -> Nothing + (row : _) -> Just row + findFirstOrFail q = do + result <- findFirst q + pure $ requireFound result (RecordNotFound "No record found matching query") + +instance ReadShelf () OmitSelect where + findMany ShelfQuery {where_, orderBy_, limit_, offset_} = + Ops.findMany @ShelfTable @ShelfRow (applyQueryModifiers where_ orderBy_ limit_ offset_) + findUnique ShelfUniqueQuery {where_} = do + let w = shelfUniqueWhere where_ + rows <- Ops.findMany @ShelfTable @ShelfRow (matching w) + pure (fromUniqueRows rows) + findUniqueOrFail q = uniqueOrFail <$> findUnique q + findFirst ShelfQuery {where_, orderBy_, limit_, offset_} = + Ops.findFirst @ShelfTable @ShelfRow (applyQueryModifiers where_ orderBy_ limit_ offset_) + findFirstOrFail q = do + result <- findFirst q + pure $ requireFound result (RecordNotFound "No record found matching query") + +instance (LoadShelf books tags) => ReadShelf (ShelfInclude books tags) ShelfSelect where + findMany ShelfQuery {include_, select_, where_, orderBy_, limit_, offset_} = do + roots <- Ops.findMany @ShelfTable @ShelfRow (prepareIncludeRootQuery @ShelfTable (applyQueryModifiers where_ orderBy_ limit_ offset_)) + loaded <- loadShelf include_ roots + pure $ map (toShelfWithPicked select_) loaded + findUnique ShelfUniqueQuery {where_, include_, select_} = do + let w = shelfUniqueWhere where_ + roots <- Ops.findMany @ShelfTable @ShelfRow (prepareIncludeRootQuery @ShelfTable (matching w)) + loaded <- loadShelf include_ roots + let rows = map (toShelfWithPicked select_) loaded + pure (fromUniqueRows rows) + findUniqueOrFail q = uniqueOrFail <$> findUnique q + findFirst ShelfQuery {select_, include_, where_, orderBy_, offset_} = do + roots <- Ops.findMany @ShelfTable @ShelfRow (prepareIncludeRootQuery @ShelfTable (applyQueryModifiers where_ orderBy_ (Just 1) offset_)) + loaded <- loadShelf include_ roots + pure $ case loaded of + [] -> Nothing + (row : _) -> Just (toShelfWithPicked select_ row) + findFirstOrFail q = do + result <- findFirst q + pure $ requireFound result (RecordNotFound "No record found matching query") + +instance ReadShelf () ShelfSelect where + findMany ShelfQuery {select_, where_, orderBy_, limit_, offset_} = + Ops.findManyWith + (parseShelfPicked select_) + (selectColumns (shelfSelectColumns select_) . applyQueryModifiers where_ orderBy_ limit_ offset_) + findUnique ShelfUniqueQuery {where_, select_} = do + let w = shelfUniqueWhere where_ + rows <- + Ops.findManyWith + (parseShelfPicked select_) + (selectColumns (shelfSelectColumns select_) . matching w) + pure (fromUniqueRows rows) + findUniqueOrFail q = uniqueOrFail <$> findUnique q + findFirst ShelfQuery {select_, where_, orderBy_, limit_, offset_} = + Ops.findFirstWith + (parseShelfPicked select_) + (selectColumns (shelfSelectColumns select_) . applyQueryModifiers where_ orderBy_ limit_ offset_) + findFirstOrFail q = do + result <- findFirst q + pure $ requireFound result (RecordNotFound "No record found matching query") + +count :: ShelfQuery include select -> Db Int +count ShelfQuery {where_, orderBy_, limit_, offset_} = + Ops.count @ShelfTable (applyQueryModifiers where_ orderBy_ limit_ offset_) + +delete :: ShelfUnique -> Db (Either ORMError Int) +delete key = + Delete.deleteMany @ShelfTable (shelfUniqueWhere key) + +deleteMany :: Where ShelfTable -> Db (Either ORMError Int) +deleteMany = Delete.deleteMany @ShelfTable diff --git a/test/Schema/Client/Tag.hs b/test/Schema/Client/Tag.hs new file mode 100644 --- /dev/null +++ b/test/Schema/Client/Tag.hs @@ -0,0 +1,213 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +module Schema.Client.Tag + ( create, + createMany, + update, + updateMany, + upsert, + findMany, + findUnique, + findUniqueOrFail, + findFirst, + findFirstOrFail, + count, + delete, + deleteMany, + TagCreate (..), + TagRow (..), + TagSelect (..), + TagPicked (..), + tagSelect, + OmitSelect (..), + Picked (..), + ResolveSelect, + TagUpdate (..), + TagTable, + TagQuery (..), + TagUnique (..), + TagUniqueKey (..), + TagUniqueQuery (..), + emptyQuery, + uniqueQuery, + tagUniqueWhere, + tagId + ) + +where + +import Data.Text (Text) +import Data.UUID (UUID) +import Poppy.Internal.Generated + ( Db, + ORMError (..), + fromUniqueRows, + requireFound, + uniqueOrFail, + OrderBy, + QueryBuilder, + applyQueryModifiers, + matching, + selectColumns, + OmitSelect (..), + Picked (..), + Where, + eq + ) +import qualified Poppy.Internal.Generated as Delete + ( deleteMany + ) +import qualified Poppy.Internal.Generated as Insert + ( insert, + insertMany, + upsert + ) +import qualified Poppy.Internal.Generated as Ops + ( findMany, + findManyWith, + findFirst, + findFirstWith, + count + ) +import qualified Poppy.Internal.Generated as Update + ( updateWhere, + updateMany + ) + +import Schema.Tag (TagCreate (..), TagRow (..), TagSelect (..), TagPicked (..), tagSelect, tagSelectColumns, parseTagPicked, TagTable, TagUpdate (..), tagId) + +data TagUnique + = ById UUID + deriving (Eq, Show) + +data TagUniqueKey + = OnId + deriving (Eq, Show) + +tagUniqueWhere :: TagUnique -> Where TagTable +tagUniqueWhere = \case + ById v1 -> eq tagId v1 + +tagConflictCols :: TagUniqueKey -> [Text] +tagConflictCols = \case + OnId -> ["id"] + + +create :: TagCreate -> Db (Either ORMError TagRow) +create = Insert.insert @TagTable @TagRow + + +createMany :: [TagCreate] -> Db (Either ORMError Int) +createMany = Insert.insertMany @TagTable + + +update :: TagUnique -> TagUpdate -> Db (Either ORMError TagRow) +update key input = + Update.updateWhere @TagTable @TagRow (tagUniqueWhere key) input + + +updateMany :: Where TagTable -> TagUpdate -> Db (Either ORMError Int) +updateMany = Update.updateMany @TagTable + + +upsert :: TagUniqueKey -> TagCreate -> TagUpdate -> Db (Either ORMError TagRow) +upsert key createInput updateInput = + Insert.upsert @TagTable @TagRow (tagConflictCols key) createInput updateInput + + +data TagQuery select = TagQuery + { select_ :: select + , where_ :: Maybe (Where TagTable) + , orderBy_ :: [OrderBy TagTable] + , limit_ :: Maybe Int + , offset_ :: Maybe Int + } + + +data TagUniqueQuery select = TagUniqueQuery + { select_ :: select + , where_ :: TagUnique + } + + +emptyQuery :: TagQuery OmitSelect +emptyQuery = + TagQuery {select_ = OmitSelect, where_ = Nothing, orderBy_ = [], limit_ = Nothing, offset_ = Nothing} + + +uniqueQuery :: TagUnique -> TagUniqueQuery OmitSelect +uniqueQuery key = + TagUniqueQuery {select_ = OmitSelect, where_ = key} + + +type family ResolveSelect select +type instance ResolveSelect OmitSelect = TagRow +type instance ResolveSelect TagSelect = TagPicked + + +class ReadTag select where + findMany :: TagQuery select -> Db [ResolveSelect select] + findUnique :: TagUniqueQuery select -> Db (Either ORMError (Maybe (ResolveSelect select))) + findUniqueOrFail :: TagUniqueQuery select -> Db (Either ORMError (ResolveSelect select)) + findFirst :: TagQuery select -> Db (Maybe (ResolveSelect select)) + findFirstOrFail :: TagQuery select -> Db (Either ORMError (ResolveSelect select)) + +instance ReadTag OmitSelect where + findMany q = + Ops.findMany @TagTable @TagRow (applyQuery q) + findUnique TagUniqueQuery {where_} = do + let w = tagUniqueWhere where_ + rows <- Ops.findMany @TagTable @TagRow (matching w) + pure (fromUniqueRows rows) + findUniqueOrFail q = uniqueOrFail <$> findUnique q + findFirst q = + Ops.findFirst @TagTable @TagRow (applyQuery q) + findFirstOrFail q = do + result <- findFirst q + pure $ requireFound result (RecordNotFound "No record found matching query") + +instance ReadTag TagSelect where + findMany q@TagQuery {select_} = + Ops.findManyWith + (parseTagPicked select_) + (selectColumns (tagSelectColumns select_) . applyQuery q) + findUnique TagUniqueQuery {where_, select_} = do + let w = tagUniqueWhere where_ + rows <- + Ops.findManyWith + (parseTagPicked select_) + (selectColumns (tagSelectColumns select_) . matching w) + pure (fromUniqueRows rows) + findUniqueOrFail q = uniqueOrFail <$> findUnique q + findFirst q@TagQuery {select_} = + Ops.findFirstWith + (parseTagPicked select_) + (selectColumns (tagSelectColumns select_) . applyQuery q) + findFirstOrFail q = do + result <- findFirst q + pure $ requireFound result (RecordNotFound "No record found matching query") + +applyQuery :: TagQuery select -> QueryBuilder TagTable -> QueryBuilder TagTable +applyQuery TagQuery {where_, orderBy_, limit_, offset_} = + applyQueryModifiers where_ orderBy_ limit_ offset_ + + +count :: TagQuery select -> Db Int +count q = Ops.count @TagTable (applyQuery q) + + +delete :: TagUnique -> Db (Either ORMError Int) +delete key = + Delete.deleteMany @TagTable (tagUniqueWhere key) + + +deleteMany :: Where TagTable -> Db (Either ORMError Int) +deleteMany = Delete.deleteMany @TagTable + diff --git a/test/Schema/Client/Widget.hs b/test/Schema/Client/Widget.hs new file mode 100644 --- /dev/null +++ b/test/Schema/Client/Widget.hs @@ -0,0 +1,217 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +module Schema.Client.Widget + ( create, + createMany, + update, + updateMany, + upsert, + findMany, + findUnique, + findUniqueOrFail, + findFirst, + findFirstOrFail, + count, + delete, + deleteMany, + WidgetCreate (..), + WidgetRow (..), + WidgetSelect (..), + WidgetPicked (..), + widgetSelect, + OmitSelect (..), + Picked (..), + ResolveSelect, + WidgetUpdate (..), + WidgetTable, + WidgetQuery (..), + WidgetUnique (..), + WidgetUniqueKey (..), + WidgetUniqueQuery (..), + emptyQuery, + uniqueQuery, + widgetUniqueWhere, + widgetId + ) + +where + +import Data.Text (Text) +import Data.UUID (UUID) +import Poppy.Internal.Generated + ( Db, + ORMError (..), + fromUniqueRows, + requireFound, + uniqueOrFail, + OrderBy, + QueryBuilder, + applyQueryModifiers, + matching, + selectColumns, + OmitSelect (..), + Picked (..), + Where, + eq + ) +import qualified Poppy.Internal.Generated as Delete + ( deleteMany + ) +import qualified Poppy.Internal.Generated as Insert + ( insert, + insertMany, + upsert + ) +import qualified Poppy.Internal.Generated as Ops + ( findMany, + findManyWith, + findFirst, + findFirstWith, + count + ) +import qualified Poppy.Internal.Generated as Update + ( updateWhere, + updateMany + ) + +import Schema.Widget (WidgetCreate (..), WidgetRow (..), WidgetSelect (..), WidgetPicked (..), widgetSelect, widgetSelectColumns, parseWidgetPicked, WidgetTable, WidgetUpdate (..), widgetId, widgetName) + +data WidgetUnique + = ById UUID + | ByName Text + deriving (Eq, Show) + +data WidgetUniqueKey + = OnId + | OnName + deriving (Eq, Show) + +widgetUniqueWhere :: WidgetUnique -> Where WidgetTable +widgetUniqueWhere = \case + ById v1 -> eq widgetId v1 + ByName v1 -> eq widgetName v1 + +widgetConflictCols :: WidgetUniqueKey -> [Text] +widgetConflictCols = \case + OnId -> ["id"] + OnName -> ["name"] + + +create :: WidgetCreate -> Db (Either ORMError WidgetRow) +create = Insert.insert @WidgetTable @WidgetRow + + +createMany :: [WidgetCreate] -> Db (Either ORMError Int) +createMany = Insert.insertMany @WidgetTable + + +update :: WidgetUnique -> WidgetUpdate -> Db (Either ORMError WidgetRow) +update key input = + Update.updateWhere @WidgetTable @WidgetRow (widgetUniqueWhere key) input + + +updateMany :: Where WidgetTable -> WidgetUpdate -> Db (Either ORMError Int) +updateMany = Update.updateMany @WidgetTable + + +upsert :: WidgetUniqueKey -> WidgetCreate -> WidgetUpdate -> Db (Either ORMError WidgetRow) +upsert key createInput updateInput = + Insert.upsert @WidgetTable @WidgetRow (widgetConflictCols key) createInput updateInput + + +data WidgetQuery select = WidgetQuery + { select_ :: select + , where_ :: Maybe (Where WidgetTable) + , orderBy_ :: [OrderBy WidgetTable] + , limit_ :: Maybe Int + , offset_ :: Maybe Int + } + + +data WidgetUniqueQuery select = WidgetUniqueQuery + { select_ :: select + , where_ :: WidgetUnique + } + + +emptyQuery :: WidgetQuery OmitSelect +emptyQuery = + WidgetQuery {select_ = OmitSelect, where_ = Nothing, orderBy_ = [], limit_ = Nothing, offset_ = Nothing} + + +uniqueQuery :: WidgetUnique -> WidgetUniqueQuery OmitSelect +uniqueQuery key = + WidgetUniqueQuery {select_ = OmitSelect, where_ = key} + + +type family ResolveSelect select +type instance ResolveSelect OmitSelect = WidgetRow +type instance ResolveSelect WidgetSelect = WidgetPicked + + +class ReadWidget select where + findMany :: WidgetQuery select -> Db [ResolveSelect select] + findUnique :: WidgetUniqueQuery select -> Db (Either ORMError (Maybe (ResolveSelect select))) + findUniqueOrFail :: WidgetUniqueQuery select -> Db (Either ORMError (ResolveSelect select)) + findFirst :: WidgetQuery select -> Db (Maybe (ResolveSelect select)) + findFirstOrFail :: WidgetQuery select -> Db (Either ORMError (ResolveSelect select)) + +instance ReadWidget OmitSelect where + findMany q = + Ops.findMany @WidgetTable @WidgetRow (applyQuery q) + findUnique WidgetUniqueQuery {where_} = do + let w = widgetUniqueWhere where_ + rows <- Ops.findMany @WidgetTable @WidgetRow (matching w) + pure (fromUniqueRows rows) + findUniqueOrFail q = uniqueOrFail <$> findUnique q + findFirst q = + Ops.findFirst @WidgetTable @WidgetRow (applyQuery q) + findFirstOrFail q = do + result <- findFirst q + pure $ requireFound result (RecordNotFound "No record found matching query") + +instance ReadWidget WidgetSelect where + findMany q@WidgetQuery {select_} = + Ops.findManyWith + (parseWidgetPicked select_) + (selectColumns (widgetSelectColumns select_) . applyQuery q) + findUnique WidgetUniqueQuery {where_, select_} = do + let w = widgetUniqueWhere where_ + rows <- + Ops.findManyWith + (parseWidgetPicked select_) + (selectColumns (widgetSelectColumns select_) . matching w) + pure (fromUniqueRows rows) + findUniqueOrFail q = uniqueOrFail <$> findUnique q + findFirst q@WidgetQuery {select_} = + Ops.findFirstWith + (parseWidgetPicked select_) + (selectColumns (widgetSelectColumns select_) . applyQuery q) + findFirstOrFail q = do + result <- findFirst q + pure $ requireFound result (RecordNotFound "No record found matching query") + +applyQuery :: WidgetQuery select -> QueryBuilder WidgetTable -> QueryBuilder WidgetTable +applyQuery WidgetQuery {where_, orderBy_, limit_, offset_} = + applyQueryModifiers where_ orderBy_ limit_ offset_ + + +count :: WidgetQuery select -> Db Int +count q = Ops.count @WidgetTable (applyQuery q) + + +delete :: WidgetUnique -> Db (Either ORMError Int) +delete key = + Delete.deleteMany @WidgetTable (widgetUniqueWhere key) + + +deleteMany :: Where WidgetTable -> Db (Either ORMError Int) +deleteMany = Delete.deleteMany @WidgetTable + diff --git a/test/Schema/Comment.hs b/test/Schema/Comment.hs new file mode 100644 --- /dev/null +++ b/test/Schema/Comment.hs @@ -0,0 +1,154 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NoFieldSelectors #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE TypeApplications #-} + +module Schema.Comment + ( CommentTable (..), + CommentRow (..), + CommentSelect (..), + CommentPicked (..), + commentSelect, + commentSelectColumns, + parseCommentPicked, + toCommentPicked, + CommentCreate (..), + CommentUpdate (..), + commentId, + commentParentId, + commentBody + ) +where + +import Data.Text (Text) +import Data.UUID (UUID) +import Poppy.Internal.Generated + ( FromRow (..), + RowParser, + field, + Entity (..), + Field (..), + PrimaryKeyType, + ModelTable, + Picked (..), + picked, + Insertable (..), + emptyInsert, + NullableValue (..), + set, + setMaybe, + setNullable, + Updatable (..), + emptyUpdate, + setFieldMaybe, + setFieldNullable + ) + +data CommentTable = CommentTable + +type instance PrimaryKeyType CommentTable = UUID + +type instance ModelTable "Comment" = CommentTable + +instance Entity CommentTable where + tableName = "test_comment" + primaryKey = commentId + tableColumns = ["id", "parent_id", "body"] + +instance Insertable CommentTable where + type CreateInput CommentTable = CommentCreate + toInsertBuilder input = + setMaybe commentId input.id $ + setNullable commentParentId input.parentId $ + set commentBody input.body $ + emptyInsert @CommentTable + + +instance Updatable CommentTable where + type UpdateInput CommentTable = CommentUpdate + updatedAtField = Nothing + toUpdateBuilder input = + setFieldNullable commentParentId input.parentId $ + setFieldMaybe commentBody input.body $ + emptyUpdate @CommentTable + + +data CommentRow = CommentRow + { id :: UUID, + parentId :: Maybe UUID, + body :: Text + } + deriving (Show, Eq) + + +data CommentCreate = CommentCreate + { id :: Maybe UUID, + parentId :: NullableValue UUID, + body :: Text + } + deriving (Show, Eq) + + +data CommentUpdate = CommentUpdate + { parentId :: NullableValue UUID, + body :: Maybe Text + } + deriving (Show, Eq) + + +instance FromRow CommentRow where + fromRow = CommentRow <$> field <*> field <*> field + + +data CommentSelect = CommentSelect + { id :: Bool, + parentId :: Bool, + body :: Bool + } + deriving (Show, Eq) +data CommentPicked = CommentPicked + { id :: UUID, + parentId :: Picked (Maybe UUID), + body :: Picked Text + } + deriving (Show, Eq) +commentSelect :: CommentSelect +commentSelect = + CommentSelect + { id = False, + parentId = False, + body = False + } +commentSelectColumns :: CommentSelect -> [Text] +commentSelectColumns select_ = + fieldColumn commentId + : concat + [ [fieldColumn commentParentId | select_.parentId] + , [fieldColumn commentBody | select_.body] + ] +parseCommentPicked :: CommentSelect -> RowParser CommentPicked +parseCommentPicked select_ = do + idVal <- field + parentIdVal <- if select_.parentId then Picked <$> field else pure Skipped + bodyVal <- if select_.body then Picked <$> field else pure Skipped + pure CommentPicked { id = idVal, parentId = parentIdVal, body = bodyVal } +toCommentPicked :: CommentSelect -> CommentRow -> CommentPicked +toCommentPicked select_ row = + CommentPicked + { id = row.id, + parentId = picked select_.parentId row.parentId, + body = picked select_.body row.body + } + + +commentId :: Field CommentTable UUID +commentId = Field "id" "id" + +commentParentId :: Field CommentTable UUID +commentParentId = Field "parentId" "parent_id" + +commentBody :: Field CommentTable Text +commentBody = Field "body" "body" + diff --git a/test/Schema/Editor.hs b/test/Schema/Editor.hs new file mode 100644 --- /dev/null +++ b/test/Schema/Editor.hs @@ -0,0 +1,136 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NoFieldSelectors #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE TypeApplications #-} + +module Schema.Editor + ( EditorTable (..), + EditorRow (..), + EditorSelect (..), + EditorPicked (..), + editorSelect, + editorSelectColumns, + parseEditorPicked, + toEditorPicked, + EditorCreate (..), + EditorUpdate (..), + editorId, + editorName + ) +where + +import Data.Text (Text) +import Data.UUID (UUID) +import Poppy.Internal.Generated + ( FromRow (..), + RowParser, + field, + Entity (..), + Field (..), + PrimaryKeyType, + ModelTable, + Picked (..), + picked, + Insertable (..), + emptyInsert, + set, + setMaybe, + Updatable (..), + emptyUpdate, + setFieldMaybe + ) + +data EditorTable = EditorTable + +type instance PrimaryKeyType EditorTable = UUID + +type instance ModelTable "Editor" = EditorTable + +instance Entity EditorTable where + tableName = "test_editor" + primaryKey = editorId + tableColumns = ["id", "name"] + +instance Insertable EditorTable where + type CreateInput EditorTable = EditorCreate + toInsertBuilder input = + setMaybe editorId input.id $ + set editorName input.name $ + emptyInsert @EditorTable + + +instance Updatable EditorTable where + type UpdateInput EditorTable = EditorUpdate + updatedAtField = Nothing + toUpdateBuilder input = + setFieldMaybe editorName input.name $ + emptyUpdate @EditorTable + + +data EditorRow = EditorRow + { id :: UUID, + name :: Text + } + deriving (Show, Eq) + + +data EditorCreate = EditorCreate + { id :: Maybe UUID, + name :: Text + } + deriving (Show, Eq) + + +data EditorUpdate = EditorUpdate + { name :: Maybe Text + } + deriving (Show, Eq) + + +instance FromRow EditorRow where + fromRow = EditorRow <$> field <*> field + + +data EditorSelect = EditorSelect + { id :: Bool, + name :: Bool + } + deriving (Show, Eq) +data EditorPicked = EditorPicked + { id :: UUID, + name :: Picked Text + } + deriving (Show, Eq) +editorSelect :: EditorSelect +editorSelect = + EditorSelect + { id = False, + name = False + } +editorSelectColumns :: EditorSelect -> [Text] +editorSelectColumns select_ = + fieldColumn editorId + : concat + [ [fieldColumn editorName | select_.name] + ] +parseEditorPicked :: EditorSelect -> RowParser EditorPicked +parseEditorPicked select_ = do + idVal <- field + nameVal <- if select_.name then Picked <$> field else pure Skipped + pure EditorPicked { id = idVal, name = nameVal } +toEditorPicked :: EditorSelect -> EditorRow -> EditorPicked +toEditorPicked select_ row = + EditorPicked + { id = row.id, + name = picked select_.name row.name + } + + +editorId :: Field EditorTable UUID +editorId = Field "id" "id" + +editorName :: Field EditorTable Text +editorName = Field "name" "name" + diff --git a/test/Schema/Include/Author.hs b/test/Schema/Include/Author.hs new file mode 100644 --- /dev/null +++ b/test/Schema/Include/Author.hs @@ -0,0 +1,214 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoFieldSelectors #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-redundant-constraints #-} + +module Schema.Include.Author + ( AuthorInclude (..) + , AuthorWith (..) + , AuthorWithPicked (..) + , AuthorPosts + , AuthorResult + , AuthorRead + , LoadAuthor (..) + , toAuthorWithPicked + , PostInclude (..) + , PostWith (..) + , PostWithPicked (..) + , PostAuthor + , PostResult + , PostRead + , LoadPost (..) + , toPostWithPicked + ) +where + +import Poppy.Internal.Generated + ( Db, + IncludeFor, + Load (..), + Skip (..), + Skipped, + ValidEdge, + skipped, + OmitSelect (..), + requireRelated, + findByIn, + indexByPk, + indexHasMany, + lookupByPk, + lookupGroups + ) +import qualified Schema.Author as Author +import Schema.Author (AuthorPicked, AuthorRow (..), AuthorSelect, AuthorTable, toAuthorPicked) +import qualified Schema.Post as Post +import Schema.Post (PostPicked, PostRow (..), PostSelect, PostTable, toPostPicked) + +data AuthorInclude posts = AuthorInclude + { posts :: posts + } + deriving (Show, Eq) + +data AuthorWith posts = AuthorWith + { author :: AuthorRow, + posts :: AuthorPosts posts + } + +deriving instance (Eq AuthorRow, Eq (AuthorPosts posts)) => Eq (AuthorWith posts) +deriving instance (Show AuthorRow, Show (AuthorPosts posts)) => Show (AuthorWith posts) + +data AuthorWithPicked posts = AuthorWithPicked + { author :: AuthorPicked, + posts :: AuthorPosts posts + } + +deriving instance (Eq AuthorPicked, Eq (AuthorPosts posts)) => Eq (AuthorWithPicked posts) +deriving instance (Show AuthorPicked, Show (AuthorPosts posts)) => Show (AuthorWithPicked posts) + +toAuthorWithPicked :: AuthorSelect -> AuthorWith posts -> AuthorWithPicked posts +toAuthorWithPicked select_ nested = + AuthorWithPicked + { author = toAuthorPicked select_ nested.author, + posts = nested.posts + } + +type family AuthorPosts edge where + AuthorPosts Skip = Skipped "posts" [PostRow] + AuthorPosts (Load PostTable include) = [PostResult include] + +type family AuthorResult include where + AuthorResult () = AuthorRow + AuthorResult (AuthorInclude posts) = AuthorWith posts + +type family AuthorRead include select where + AuthorRead () OmitSelect = AuthorRow + AuthorRead () AuthorSelect = AuthorPicked + AuthorRead (AuthorInclude posts) OmitSelect = AuthorWith posts + AuthorRead (AuthorInclude posts) AuthorSelect = AuthorWithPicked posts + +data PostInclude author = PostInclude + { author :: author + } + deriving (Show, Eq) + +data PostWith author = PostWith + { post :: PostRow, + author :: PostAuthor author + } + +deriving instance (Eq PostRow, Eq (PostAuthor author)) => Eq (PostWith author) +deriving instance (Show PostRow, Show (PostAuthor author)) => Show (PostWith author) + +data PostWithPicked author = PostWithPicked + { post :: PostPicked, + author :: PostAuthor author + } + +deriving instance (Eq PostPicked, Eq (PostAuthor author)) => Eq (PostWithPicked author) +deriving instance (Show PostPicked, Show (PostAuthor author)) => Show (PostWithPicked author) + +toPostWithPicked :: PostSelect -> PostWith author -> PostWithPicked author +toPostWithPicked select_ nested = + PostWithPicked + { post = toPostPicked select_ nested.post, + author = nested.author + } + +type family PostAuthor edge where + PostAuthor Skip = Skipped "author" AuthorRow + PostAuthor (Load AuthorTable include) = AuthorResult include + +type family PostResult include where + PostResult () = PostRow + PostResult (PostInclude author) = PostWith author + +type family PostRead include select where + PostRead () OmitSelect = PostRow + PostRead () PostSelect = PostPicked + PostRead (PostInclude author) OmitSelect = PostWith author + PostRead (PostInclude author) PostSelect = PostWithPicked author + +class LoadAuthorPosts edge where + loadAuthorPosts :: edge -> [AuthorRow] -> Db [AuthorPosts edge] + +instance LoadAuthorPosts Skip where + loadAuthorPosts Skip roots = pure (map (const skipped) roots) + +instance LoadAuthorPosts (Load PostTable ()) where + loadAuthorPosts edge roots = do + rows <- findByIn @PostTable @PostRow Post.postAuthorId (map (.id) roots) edge.where_ edge.orderBy_ edge.take_ + let grouped = indexHasMany (.authorId) rows + pure [lookupGroups root.id grouped | root <- roots] + +instance (LoadPost author) => LoadAuthorPosts (Load PostTable (PostInclude author)) where + loadAuthorPosts edge roots = do + rows <- findByIn @PostTable @PostRow Post.postAuthorId (map (.id) roots) edge.where_ edge.orderBy_ edge.take_ + loaded <- loadPost edge.include_ rows + let grouped = indexHasMany ((.authorId) . (.post)) loaded + pure [lookupGroups root.id grouped | root <- roots] + +instance {-# OVERLAPPABLE #-} (ValidEdge "Post" edge) => LoadAuthorPosts edge where + loadAuthorPosts _ roots = pure (map (const skipped) roots) + +class LoadAuthor posts where + loadAuthor :: AuthorInclude posts -> [AuthorRow] -> Db [AuthorWith posts] + +instance (LoadAuthorPosts posts, ValidEdge "Post" posts) => LoadAuthor posts where + loadAuthor include roots = do + postsLoaded <- loadAuthorPosts include.posts roots + pure + [ AuthorWith + { author = root, + posts = postsLoaded !! n + } + | (n, root) <- zip [0 :: Int ..] roots + ] + +instance (ValidEdge "Post" posts) => IncludeFor "Author" (AuthorInclude posts) + +class LoadPostAuthor edge where + loadPostAuthor :: edge -> [PostRow] -> Db [PostAuthor edge] + +instance LoadPostAuthor Skip where + loadPostAuthor Skip roots = pure (map (const skipped) roots) + +instance LoadPostAuthor (Load AuthorTable ()) where + loadPostAuthor edge roots = do + rows <- findByIn @AuthorTable @AuthorRow Author.authorId (map (.authorId) roots) edge.where_ edge.orderBy_ edge.take_ + let indexed = indexByPk (.id) rows + pure [requireRelated "author" (lookupByPk root.authorId indexed) | root <- roots] + +instance (LoadAuthor posts) => LoadPostAuthor (Load AuthorTable (AuthorInclude posts)) where + loadPostAuthor edge roots = do + rows <- findByIn @AuthorTable @AuthorRow Author.authorId (map (.authorId) roots) edge.where_ edge.orderBy_ edge.take_ + loaded <- loadAuthor edge.include_ rows + let indexed = indexByPk ((.id) . (.author)) loaded + pure [requireRelated "author" (lookupByPk root.authorId indexed) | root <- roots] + +instance {-# OVERLAPPABLE #-} (ValidEdge "Author" edge) => LoadPostAuthor edge where + loadPostAuthor _ roots = pure (map (const skipped) roots) + +class LoadPost author where + loadPost :: PostInclude author -> [PostRow] -> Db [PostWith author] + +instance (LoadPostAuthor author, ValidEdge "Author" author) => LoadPost author where + loadPost include roots = do + authorLoaded <- loadPostAuthor include.author roots + pure + [ PostWith + { post = root, + author = authorLoaded !! n + } + | (n, root) <- zip [0 :: Int ..] roots + ] + +instance (ValidEdge "Author" author) => IncludeFor "Post" (PostInclude author) + diff --git a/test/Schema/Include/Book.hs b/test/Schema/Include/Book.hs new file mode 100644 --- /dev/null +++ b/test/Schema/Include/Book.hs @@ -0,0 +1,123 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoFieldSelectors #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-redundant-constraints #-} + +module Schema.Include.Book + ( BookInclude (..) + , BookWith (..) + , BookWithPicked (..) + , BookChapters + , BookResult + , BookRead + , LoadBook (..) + , toBookWithPicked + ) +where + +import Poppy.Internal.Generated + ( Db, + IncludeFor, + Load (..), + Skip (..), + Skipped, + ValidEdge, + skipped, + OmitSelect (..), + findByIn, + indexHasMany, + lookupGroups + ) +import Schema.Book (BookPicked, BookRow (..), BookSelect, toBookPicked) +import qualified Schema.Chapter as Chapter +import Schema.Chapter (ChapterRow (..), ChapterTable) +import Schema.Include.Chapter (ChapterInclude (..), ChapterResult, ChapterWith (..), LoadChapter (..)) + +data BookInclude chapters = BookInclude + { chapters :: chapters + } + deriving (Show, Eq) + +data BookWith chapters = BookWith + { book :: BookRow, + chapters :: BookChapters chapters + } + +deriving instance (Eq BookRow, Eq (BookChapters chapters)) => Eq (BookWith chapters) +deriving instance (Show BookRow, Show (BookChapters chapters)) => Show (BookWith chapters) + +data BookWithPicked chapters = BookWithPicked + { book :: BookPicked, + chapters :: BookChapters chapters + } + +deriving instance (Eq BookPicked, Eq (BookChapters chapters)) => Eq (BookWithPicked chapters) +deriving instance (Show BookPicked, Show (BookChapters chapters)) => Show (BookWithPicked chapters) + +toBookWithPicked :: BookSelect -> BookWith chapters -> BookWithPicked chapters +toBookWithPicked select_ nested = + BookWithPicked + { book = toBookPicked select_ nested.book, + chapters = nested.chapters + } + +type family BookChapters edge where + BookChapters Skip = Skipped "chapters" [ChapterRow] + BookChapters (Load ChapterTable include) = [ChapterResult include] + +type family BookResult include where + BookResult () = BookRow + BookResult (BookInclude chapters) = BookWith chapters + +type family BookRead include select where + BookRead () OmitSelect = BookRow + BookRead () BookSelect = BookPicked + BookRead (BookInclude chapters) OmitSelect = BookWith chapters + BookRead (BookInclude chapters) BookSelect = BookWithPicked chapters + +class LoadBookChapters edge where + loadBookChapters :: edge -> [BookRow] -> Db [BookChapters edge] + +instance LoadBookChapters Skip where + loadBookChapters Skip roots = pure (map (const skipped) roots) + +instance LoadBookChapters (Load ChapterTable ()) where + loadBookChapters edge roots = do + rows <- findByIn @ChapterTable @ChapterRow Chapter.chapterBookRef (map (.id) roots) edge.where_ edge.orderBy_ edge.take_ + let grouped = indexHasMany (.bookRef) rows + pure [lookupGroups root.id grouped | root <- roots] + +instance (LoadChapter sections) => LoadBookChapters (Load ChapterTable (ChapterInclude sections)) where + loadBookChapters edge roots = do + rows <- findByIn @ChapterTable @ChapterRow Chapter.chapterBookRef (map (.id) roots) edge.where_ edge.orderBy_ edge.take_ + loaded <- loadChapter edge.include_ rows + let grouped = indexHasMany ((.bookRef) . (.chapter)) loaded + pure [lookupGroups root.id grouped | root <- roots] + +instance {-# OVERLAPPABLE #-} (ValidEdge "Chapter" edge) => LoadBookChapters edge where + loadBookChapters _ roots = pure (map (const skipped) roots) + +class LoadBook chapters where + loadBook :: BookInclude chapters -> [BookRow] -> Db [BookWith chapters] + +instance (LoadBookChapters chapters, ValidEdge "Chapter" chapters) => LoadBook chapters where + loadBook include roots = do + chaptersLoaded <- loadBookChapters include.chapters roots + pure + [ BookWith + { book = root, + chapters = chaptersLoaded !! n + } + | (n, root) <- zip [0 :: Int ..] roots + ] + +instance (ValidEdge "Chapter" chapters) => IncludeFor "Book" (BookInclude chapters) + diff --git a/test/Schema/Include/Chapter.hs b/test/Schema/Include/Chapter.hs new file mode 100644 --- /dev/null +++ b/test/Schema/Include/Chapter.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoFieldSelectors #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-redundant-constraints #-} + +module Schema.Include.Chapter + ( ChapterInclude (..) + , ChapterWith (..) + , ChapterWithPicked (..) + , ChapterSections + , ChapterResult + , ChapterRead + , LoadChapter (..) + , toChapterWithPicked + ) +where + +import Poppy.Internal.Generated + ( Db, + IncludeFor, + Load (..), + Skip (..), + Skipped, + ValidEdge, + skipped, + OmitSelect (..), + findByIn, + indexHasMany, + lookupGroups + ) +import Schema.Chapter (ChapterPicked, ChapterRow (..), ChapterSelect, toChapterPicked) +import qualified Schema.Section as Section +import Schema.Section (SectionRow (..), SectionTable) + +data ChapterInclude sections = ChapterInclude + { sections :: sections + } + deriving (Show, Eq) + +data ChapterWith sections = ChapterWith + { chapter :: ChapterRow, + sections :: ChapterSections sections + } + +deriving instance (Eq ChapterRow, Eq (ChapterSections sections)) => Eq (ChapterWith sections) +deriving instance (Show ChapterRow, Show (ChapterSections sections)) => Show (ChapterWith sections) + +data ChapterWithPicked sections = ChapterWithPicked + { chapter :: ChapterPicked, + sections :: ChapterSections sections + } + +deriving instance (Eq ChapterPicked, Eq (ChapterSections sections)) => Eq (ChapterWithPicked sections) +deriving instance (Show ChapterPicked, Show (ChapterSections sections)) => Show (ChapterWithPicked sections) + +toChapterWithPicked :: ChapterSelect -> ChapterWith sections -> ChapterWithPicked sections +toChapterWithPicked select_ nested = + ChapterWithPicked + { chapter = toChapterPicked select_ nested.chapter, + sections = nested.sections + } + +type family ChapterSections edge where + ChapterSections Skip = Skipped "sections" [SectionRow] + ChapterSections (Load SectionTable ()) = [SectionRow] + +type family ChapterResult include where + ChapterResult () = ChapterRow + ChapterResult (ChapterInclude sections) = ChapterWith sections + +type family ChapterRead include select where + ChapterRead () OmitSelect = ChapterRow + ChapterRead () ChapterSelect = ChapterPicked + ChapterRead (ChapterInclude sections) OmitSelect = ChapterWith sections + ChapterRead (ChapterInclude sections) ChapterSelect = ChapterWithPicked sections + +class LoadChapterSections edge where + loadChapterSections :: edge -> [ChapterRow] -> Db [ChapterSections edge] + +instance LoadChapterSections Skip where + loadChapterSections Skip roots = pure (map (const skipped) roots) + +instance LoadChapterSections (Load SectionTable ()) where + loadChapterSections edge roots = do + rows <- findByIn @SectionTable @SectionRow Section.sectionChapterRef (map (.id) roots) edge.where_ edge.orderBy_ edge.take_ + let grouped = indexHasMany (.chapterRef) rows + pure [lookupGroups root.id grouped | root <- roots] + +instance {-# OVERLAPPABLE #-} (ValidEdge "Section" edge) => LoadChapterSections edge where + loadChapterSections _ roots = pure (map (const skipped) roots) + +class LoadChapter sections where + loadChapter :: ChapterInclude sections -> [ChapterRow] -> Db [ChapterWith sections] + +instance (LoadChapterSections sections, ValidEdge "Section" sections) => LoadChapter sections where + loadChapter include roots = do + sectionsLoaded <- loadChapterSections include.sections roots + pure + [ ChapterWith + { chapter = root, + sections = sectionsLoaded !! n + } + | (n, root) <- zip [0 :: Int ..] roots + ] + +instance (ValidEdge "Section" sections) => IncludeFor "Chapter" (ChapterInclude sections) + diff --git a/test/Schema/Include/Comment.hs b/test/Schema/Include/Comment.hs new file mode 100644 --- /dev/null +++ b/test/Schema/Include/Comment.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoFieldSelectors #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-redundant-constraints #-} + +module Schema.Include.Comment + ( CommentInclude (..) + , CommentWith (..) + , CommentWithPicked (..) + , CommentReplies + , CommentResult + , CommentRead + , LoadComment (..) + , toCommentWithPicked + ) +where + +import Poppy.Internal.Generated + ( Db, + IncludeFor, + Load (..), + Skip (..), + Skipped, + ValidEdge, + skipped, + OmitSelect (..), + findByIn, + indexHasManyMaybe, + lookupGroups + ) +import qualified Schema.Comment as Comment +import Schema.Comment (CommentPicked, CommentRow (..), CommentSelect, CommentTable, toCommentPicked) + +data CommentInclude replies = CommentInclude + { replies :: replies + } + deriving (Show, Eq) + +data CommentWith replies = CommentWith + { comment :: CommentRow, + replies :: CommentReplies replies + } + +deriving instance (Eq CommentRow, Eq (CommentReplies replies)) => Eq (CommentWith replies) +deriving instance (Show CommentRow, Show (CommentReplies replies)) => Show (CommentWith replies) + +data CommentWithPicked replies = CommentWithPicked + { comment :: CommentPicked, + replies :: CommentReplies replies + } + +deriving instance (Eq CommentPicked, Eq (CommentReplies replies)) => Eq (CommentWithPicked replies) +deriving instance (Show CommentPicked, Show (CommentReplies replies)) => Show (CommentWithPicked replies) + +toCommentWithPicked :: CommentSelect -> CommentWith replies -> CommentWithPicked replies +toCommentWithPicked select_ nested = + CommentWithPicked + { comment = toCommentPicked select_ nested.comment, + replies = nested.replies + } + +type family CommentReplies edge where + CommentReplies Skip = Skipped "replies" [CommentRow] + CommentReplies (Load CommentTable include) = [CommentResult include] + +type family CommentResult include where + CommentResult () = CommentRow + CommentResult (CommentInclude replies) = CommentWith replies + +type family CommentRead include select where + CommentRead () OmitSelect = CommentRow + CommentRead () CommentSelect = CommentPicked + CommentRead (CommentInclude replies) OmitSelect = CommentWith replies + CommentRead (CommentInclude replies) CommentSelect = CommentWithPicked replies + +class LoadCommentReplies edge where + loadCommentReplies :: edge -> [CommentRow] -> Db [CommentReplies edge] + +instance LoadCommentReplies Skip where + loadCommentReplies Skip roots = pure (map (const skipped) roots) + +instance LoadCommentReplies (Load CommentTable ()) where + loadCommentReplies edge roots = do + rows <- findByIn @CommentTable @CommentRow Comment.commentParentId (map (.id) roots) edge.where_ edge.orderBy_ edge.take_ + let grouped = indexHasManyMaybe (.parentId) rows + pure [lookupGroups root.id grouped | root <- roots] + +instance (LoadComment replies) => LoadCommentReplies (Load CommentTable (CommentInclude replies)) where + loadCommentReplies edge roots = do + rows <- findByIn @CommentTable @CommentRow Comment.commentParentId (map (.id) roots) edge.where_ edge.orderBy_ edge.take_ + loaded <- loadComment edge.include_ rows + let grouped = indexHasManyMaybe ((.parentId) . (.comment)) loaded + pure [lookupGroups root.id grouped | root <- roots] + +instance {-# OVERLAPPABLE #-} (ValidEdge "Comment" edge) => LoadCommentReplies edge where + loadCommentReplies _ roots = pure (map (const skipped) roots) + +class LoadComment replies where + loadComment :: CommentInclude replies -> [CommentRow] -> Db [CommentWith replies] + +instance (LoadCommentReplies replies, ValidEdge "Comment" replies) => LoadComment replies where + loadComment include roots = do + repliesLoaded <- loadCommentReplies include.replies roots + pure + [ CommentWith + { comment = root, + replies = repliesLoaded !! n + } + | (n, root) <- zip [0 :: Int ..] roots + ] + +instance (ValidEdge "Comment" replies) => IncludeFor "Comment" (CommentInclude replies) + diff --git a/test/Schema/Include/Editor.hs b/test/Schema/Include/Editor.hs new file mode 100644 --- /dev/null +++ b/test/Schema/Include/Editor.hs @@ -0,0 +1,141 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoFieldSelectors #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-redundant-constraints #-} + +module Schema.Include.Editor + ( EditorInclude (..) + , EditorWith (..) + , EditorWithPicked (..) + , EditorWrittenPosts + , EditorEditedPosts + , EditorResult + , EditorRead + , LoadEditor (..) + , toEditorWithPicked + ) +where + +import Poppy.Internal.Generated + ( Db, + IncludeFor, + Load (..), + Skip (..), + Skipped, + ValidEdge, + skipped, + OmitSelect (..), + findByIn, + indexHasMany, + lookupGroups + ) +import Schema.Editor (EditorPicked, EditorRow (..), EditorSelect, toEditorPicked) +import qualified Schema.Article as Article +import Schema.Article (ArticleRow (..), ArticleTable) + +data EditorInclude writtenPosts editedPosts = EditorInclude + { writtenPosts :: writtenPosts, + editedPosts :: editedPosts + } + deriving (Show, Eq) + +data EditorWith writtenPosts editedPosts = EditorWith + { editor :: EditorRow, + writtenPosts :: EditorWrittenPosts writtenPosts, + editedPosts :: EditorEditedPosts editedPosts + } + +deriving instance (Eq EditorRow, Eq (EditorWrittenPosts writtenPosts), Eq (EditorEditedPosts editedPosts)) => Eq (EditorWith writtenPosts editedPosts) +deriving instance (Show EditorRow, Show (EditorWrittenPosts writtenPosts), Show (EditorEditedPosts editedPosts)) => Show (EditorWith writtenPosts editedPosts) + +data EditorWithPicked writtenPosts editedPosts = EditorWithPicked + { editor :: EditorPicked, + writtenPosts :: EditorWrittenPosts writtenPosts, + editedPosts :: EditorEditedPosts editedPosts + } + +deriving instance (Eq EditorPicked, Eq (EditorWrittenPosts writtenPosts), Eq (EditorEditedPosts editedPosts)) => Eq (EditorWithPicked writtenPosts editedPosts) +deriving instance (Show EditorPicked, Show (EditorWrittenPosts writtenPosts), Show (EditorEditedPosts editedPosts)) => Show (EditorWithPicked writtenPosts editedPosts) + +toEditorWithPicked :: EditorSelect -> EditorWith writtenPosts editedPosts -> EditorWithPicked writtenPosts editedPosts +toEditorWithPicked select_ nested = + EditorWithPicked + { editor = toEditorPicked select_ nested.editor, + writtenPosts = nested.writtenPosts, + editedPosts = nested.editedPosts + } + +type family EditorWrittenPosts edge where + EditorWrittenPosts Skip = Skipped "writtenPosts" [ArticleRow] + EditorWrittenPosts (Load ArticleTable ()) = [ArticleRow] + +type family EditorEditedPosts edge where + EditorEditedPosts Skip = Skipped "editedPosts" [ArticleRow] + EditorEditedPosts (Load ArticleTable ()) = [ArticleRow] + +type family EditorResult include where + EditorResult () = EditorRow + EditorResult (EditorInclude writtenPosts editedPosts) = EditorWith writtenPosts editedPosts + +type family EditorRead include select where + EditorRead () OmitSelect = EditorRow + EditorRead () EditorSelect = EditorPicked + EditorRead (EditorInclude writtenPosts editedPosts) OmitSelect = EditorWith writtenPosts editedPosts + EditorRead (EditorInclude writtenPosts editedPosts) EditorSelect = EditorWithPicked writtenPosts editedPosts + +class LoadEditorWrittenPosts edge where + loadEditorWrittenPosts :: edge -> [EditorRow] -> Db [EditorWrittenPosts edge] + +instance LoadEditorWrittenPosts Skip where + loadEditorWrittenPosts Skip roots = pure (map (const skipped) roots) + +instance LoadEditorWrittenPosts (Load ArticleTable ()) where + loadEditorWrittenPosts edge roots = do + rows <- findByIn @ArticleTable @ArticleRow Article.articleAuthorId (map (.id) roots) edge.where_ edge.orderBy_ edge.take_ + let grouped = indexHasMany (.authorId) rows + pure [lookupGroups root.id grouped | root <- roots] + +instance {-# OVERLAPPABLE #-} (ValidEdge "Article" edge) => LoadEditorWrittenPosts edge where + loadEditorWrittenPosts _ roots = pure (map (const skipped) roots) + +class LoadEditorEditedPosts edge where + loadEditorEditedPosts :: edge -> [EditorRow] -> Db [EditorEditedPosts edge] + +instance LoadEditorEditedPosts Skip where + loadEditorEditedPosts Skip roots = pure (map (const skipped) roots) + +instance LoadEditorEditedPosts (Load ArticleTable ()) where + loadEditorEditedPosts edge roots = do + rows <- findByIn @ArticleTable @ArticleRow Article.articleAuthorId (map (.id) roots) edge.where_ edge.orderBy_ edge.take_ + let grouped = indexHasMany (.authorId) rows + pure [lookupGroups root.id grouped | root <- roots] + +instance {-# OVERLAPPABLE #-} (ValidEdge "Article" edge) => LoadEditorEditedPosts edge where + loadEditorEditedPosts _ roots = pure (map (const skipped) roots) + +class LoadEditor writtenPosts editedPosts where + loadEditor :: EditorInclude writtenPosts editedPosts -> [EditorRow] -> Db [EditorWith writtenPosts editedPosts] + +instance (LoadEditorWrittenPosts writtenPosts, LoadEditorEditedPosts editedPosts, ValidEdge "Article" writtenPosts, ValidEdge "Article" editedPosts) => LoadEditor writtenPosts editedPosts where + loadEditor include roots = do + writtenPostsLoaded <- loadEditorWrittenPosts include.writtenPosts roots + editedPostsLoaded <- loadEditorEditedPosts include.editedPosts roots + pure + [ EditorWith + { editor = root, + writtenPosts = writtenPostsLoaded !! n, + editedPosts = editedPostsLoaded !! n + } + | (n, root) <- zip [0 :: Int ..] roots + ] + +instance (ValidEdge "Article" writtenPosts, ValidEdge "Article" editedPosts) => IncludeFor "Editor" (EditorInclude writtenPosts editedPosts) + diff --git a/test/Schema/Include/Post.hs b/test/Schema/Include/Post.hs new file mode 100644 --- /dev/null +++ b/test/Schema/Include/Post.hs @@ -0,0 +1,13 @@ +module Schema.Include.Post + ( PostInclude (..) + , PostWith (..) + , PostWithPicked (..) + , PostAuthor + , PostResult + , PostRead + , LoadPost (..) + , toPostWithPicked + ) +where + +import Schema.Include.Author (PostInclude (..), PostWith (..), PostWithPicked (..), PostAuthor, PostResult, PostRead, LoadPost (..), toPostWithPicked) diff --git a/test/Schema/Include/Shelf.hs b/test/Schema/Include/Shelf.hs new file mode 100644 --- /dev/null +++ b/test/Schema/Include/Shelf.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoFieldSelectors #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-redundant-constraints #-} + +module Schema.Include.Shelf + ( ShelfInclude (..) + , ShelfWith (..) + , ShelfWithPicked (..) + , ShelfBooks + , ShelfTags + , ShelfResult + , ShelfRead + , LoadShelf (..) + , toShelfWithPicked + ) +where + +import Poppy.Internal.Generated + ( Db, + IncludeFor, + Load (..), + Skip (..), + Skipped, + ValidEdge, + skipped, + OmitSelect (..), + findByIn, + indexHasMany, + lookupGroups + ) +import Schema.Shelf (ShelfPicked, ShelfRow (..), ShelfSelect, toShelfPicked) +import qualified Schema.Book as Book +import Schema.Book (BookRow (..), BookTable) +import qualified Schema.Tag as Tag +import Schema.Tag (TagRow (..), TagTable) +import Schema.Include.Book (BookInclude (..), BookResult, BookWith (..), LoadBook (..)) + +data ShelfInclude books tags = ShelfInclude + { books :: books, + tags :: tags + } + deriving (Show, Eq) + +data ShelfWith books tags = ShelfWith + { shelf :: ShelfRow, + books :: ShelfBooks books, + tags :: ShelfTags tags + } + +deriving instance (Eq ShelfRow, Eq (ShelfBooks books), Eq (ShelfTags tags)) => Eq (ShelfWith books tags) +deriving instance (Show ShelfRow, Show (ShelfBooks books), Show (ShelfTags tags)) => Show (ShelfWith books tags) + +data ShelfWithPicked books tags = ShelfWithPicked + { shelf :: ShelfPicked, + books :: ShelfBooks books, + tags :: ShelfTags tags + } + +deriving instance (Eq ShelfPicked, Eq (ShelfBooks books), Eq (ShelfTags tags)) => Eq (ShelfWithPicked books tags) +deriving instance (Show ShelfPicked, Show (ShelfBooks books), Show (ShelfTags tags)) => Show (ShelfWithPicked books tags) + +toShelfWithPicked :: ShelfSelect -> ShelfWith books tags -> ShelfWithPicked books tags +toShelfWithPicked select_ nested = + ShelfWithPicked + { shelf = toShelfPicked select_ nested.shelf, + books = nested.books, + tags = nested.tags + } + +type family ShelfBooks edge where + ShelfBooks Skip = Skipped "books" [BookRow] + ShelfBooks (Load BookTable include) = [BookResult include] + +type family ShelfTags edge where + ShelfTags Skip = Skipped "tags" [TagRow] + ShelfTags (Load TagTable ()) = [TagRow] + +type family ShelfResult include where + ShelfResult () = ShelfRow + ShelfResult (ShelfInclude books tags) = ShelfWith books tags + +type family ShelfRead include select where + ShelfRead () OmitSelect = ShelfRow + ShelfRead () ShelfSelect = ShelfPicked + ShelfRead (ShelfInclude books tags) OmitSelect = ShelfWith books tags + ShelfRead (ShelfInclude books tags) ShelfSelect = ShelfWithPicked books tags + +class LoadShelfBooks edge where + loadShelfBooks :: edge -> [ShelfRow] -> Db [ShelfBooks edge] + +instance LoadShelfBooks Skip where + loadShelfBooks Skip roots = pure (map (const skipped) roots) + +instance LoadShelfBooks (Load BookTable ()) where + loadShelfBooks edge roots = do + rows <- findByIn @BookTable @BookRow Book.bookShelfId (map (.id) roots) edge.where_ edge.orderBy_ edge.take_ + let grouped = indexHasMany (.shelfId) rows + pure [lookupGroups root.id grouped | root <- roots] + +instance (LoadBook chapters) => LoadShelfBooks (Load BookTable (BookInclude chapters)) where + loadShelfBooks edge roots = do + rows <- findByIn @BookTable @BookRow Book.bookShelfId (map (.id) roots) edge.where_ edge.orderBy_ edge.take_ + loaded <- loadBook edge.include_ rows + let grouped = indexHasMany ((.shelfId) . (.book)) loaded + pure [lookupGroups root.id grouped | root <- roots] + +instance {-# OVERLAPPABLE #-} (ValidEdge "Book" edge) => LoadShelfBooks edge where + loadShelfBooks _ roots = pure (map (const skipped) roots) + +class LoadShelfTags edge where + loadShelfTags :: edge -> [ShelfRow] -> Db [ShelfTags edge] + +instance LoadShelfTags Skip where + loadShelfTags Skip roots = pure (map (const skipped) roots) + +instance LoadShelfTags (Load TagTable ()) where + loadShelfTags edge roots = do + rows <- findByIn @TagTable @TagRow Tag.tagShelfId (map (.id) roots) edge.where_ edge.orderBy_ edge.take_ + let grouped = indexHasMany (.shelfId) rows + pure [lookupGroups root.id grouped | root <- roots] + +instance {-# OVERLAPPABLE #-} (ValidEdge "Tag" edge) => LoadShelfTags edge where + loadShelfTags _ roots = pure (map (const skipped) roots) + +class LoadShelf books tags where + loadShelf :: ShelfInclude books tags -> [ShelfRow] -> Db [ShelfWith books tags] + +instance (LoadShelfBooks books, LoadShelfTags tags, ValidEdge "Book" books, ValidEdge "Tag" tags) => LoadShelf books tags where + loadShelf include roots = do + booksLoaded <- loadShelfBooks include.books roots + tagsLoaded <- loadShelfTags include.tags roots + pure + [ ShelfWith + { shelf = root, + books = booksLoaded !! n, + tags = tagsLoaded !! n + } + | (n, root) <- zip [0 :: Int ..] roots + ] + +instance (ValidEdge "Book" books, ValidEdge "Tag" tags) => IncludeFor "Shelf" (ShelfInclude books tags) + diff --git a/test/Schema/Packet.hs b/test/Schema/Packet.hs new file mode 100644 --- /dev/null +++ b/test/Schema/Packet.hs @@ -0,0 +1,153 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NoFieldSelectors #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE TypeApplications #-} + +module Schema.Packet + ( PacketTable (..), + PacketRow (..), + PacketSelect (..), + PacketPicked (..), + packetSelect, + packetSelectColumns, + parsePacketPicked, + toPacketPicked, + PacketCreate (..), + PacketUpdate (..), + packetId, + packetAmount, + packetPayload + ) +where + +import Data.Text (Text) +import Data.UUID (UUID) +import Data.Scientific (Scientific) +import Data.Aeson (Value) +import Poppy.Internal.Generated + ( FromRow (..), + RowParser, + field, + Entity (..), + Field (..), + PrimaryKeyType, + ModelTable, + Picked (..), + picked, + Insertable (..), + emptyInsert, + set, + setMaybe, + Updatable (..), + emptyUpdate, + setFieldMaybe + ) + +data PacketTable = PacketTable + +type instance PrimaryKeyType PacketTable = UUID + +type instance ModelTable "Packet" = PacketTable + +instance Entity PacketTable where + tableName = "test_packet" + primaryKey = packetId + tableColumns = ["id", "amount", "payload"] + +instance Insertable PacketTable where + type CreateInput PacketTable = PacketCreate + toInsertBuilder input = + setMaybe packetId input.id $ + set packetAmount input.amount $ + set packetPayload input.payload $ + emptyInsert @PacketTable + + +instance Updatable PacketTable where + type UpdateInput PacketTable = PacketUpdate + updatedAtField = Nothing + toUpdateBuilder input = + setFieldMaybe packetAmount input.amount $ + setFieldMaybe packetPayload input.payload $ + emptyUpdate @PacketTable + + +data PacketRow = PacketRow + { id :: UUID, + amount :: Scientific, + payload :: Value + } + deriving (Show, Eq) + + +data PacketCreate = PacketCreate + { id :: Maybe UUID, + amount :: Scientific, + payload :: Value + } + deriving (Show, Eq) + + +data PacketUpdate = PacketUpdate + { amount :: Maybe Scientific, + payload :: Maybe Value + } + deriving (Show, Eq) + + +instance FromRow PacketRow where + fromRow = PacketRow <$> field <*> field <*> field + + +data PacketSelect = PacketSelect + { id :: Bool, + amount :: Bool, + payload :: Bool + } + deriving (Show, Eq) +data PacketPicked = PacketPicked + { id :: UUID, + amount :: Picked Scientific, + payload :: Picked Value + } + deriving (Show, Eq) +packetSelect :: PacketSelect +packetSelect = + PacketSelect + { id = False, + amount = False, + payload = False + } +packetSelectColumns :: PacketSelect -> [Text] +packetSelectColumns select_ = + fieldColumn packetId + : concat + [ [fieldColumn packetAmount | select_.amount] + , [fieldColumn packetPayload | select_.payload] + ] +parsePacketPicked :: PacketSelect -> RowParser PacketPicked +parsePacketPicked select_ = do + idVal <- field + amountVal <- if select_.amount then Picked <$> field else pure Skipped + payloadVal <- if select_.payload then Picked <$> field else pure Skipped + pure PacketPicked { id = idVal, amount = amountVal, payload = payloadVal } +toPacketPicked :: PacketSelect -> PacketRow -> PacketPicked +toPacketPicked select_ row = + PacketPicked + { id = row.id, + amount = picked select_.amount row.amount, + payload = picked select_.payload row.payload + } + + +packetId :: Field PacketTable UUID +packetId = Field "id" "id" + +packetAmount :: Field PacketTable Scientific +packetAmount = Field "amount" "amount" + +packetPayload :: Field PacketTable Value +packetPayload = Field "payload" "payload" + diff --git a/test/Schema/Post.hs b/test/Schema/Post.hs new file mode 100644 --- /dev/null +++ b/test/Schema/Post.hs @@ -0,0 +1,167 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NoFieldSelectors #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE TypeApplications #-} + +module Schema.Post + ( PostTable (..), + PostRow (..), + PostSelect (..), + PostPicked (..), + postSelect, + postSelectColumns, + parsePostPicked, + toPostPicked, + PostCreate (..), + PostUpdate (..), + postId, + postAuthorId, + postTitle, + postStatus + ) +where + +import Data.Text (Text) +import Data.UUID (UUID) +import Poppy.Internal.Generated + ( FromRow (..), + RowParser, + field, + Entity (..), + Field (..), + PrimaryKeyType, + ModelTable, + Picked (..), + picked, + Insertable (..), + emptyInsert, + set, + setMaybe, + Updatable (..), + emptyUpdate, + setFieldMaybe + ) +import Schema.PostStatus (PostStatus) + +data PostTable = PostTable + +type instance PrimaryKeyType PostTable = UUID + +type instance ModelTable "Post" = PostTable + +instance Entity PostTable where + tableName = "test_post" + primaryKey = postId + tableColumns = ["id", "author_id", "title", "status"] + +instance Insertable PostTable where + type CreateInput PostTable = PostCreate + toInsertBuilder input = + setMaybe postId input.id $ + set postAuthorId input.authorId $ + set postTitle input.title $ + set postStatus input.status $ + emptyInsert @PostTable + + +instance Updatable PostTable where + type UpdateInput PostTable = PostUpdate + updatedAtField = Nothing + toUpdateBuilder input = + setFieldMaybe postAuthorId input.authorId $ + setFieldMaybe postTitle input.title $ + setFieldMaybe postStatus input.status $ + emptyUpdate @PostTable + + +data PostRow = PostRow + { id :: UUID, + authorId :: UUID, + title :: Text, + status :: PostStatus + } + deriving (Show, Eq) + + +data PostCreate = PostCreate + { id :: Maybe UUID, + authorId :: UUID, + title :: Text, + status :: PostStatus + } + deriving (Show, Eq) + + +data PostUpdate = PostUpdate + { authorId :: Maybe UUID, + title :: Maybe Text, + status :: Maybe PostStatus + } + deriving (Show, Eq) + + +instance FromRow PostRow where + fromRow = PostRow <$> field <*> field <*> field <*> field + + +data PostSelect = PostSelect + { id :: Bool, + authorId :: Bool, + title :: Bool, + status :: Bool + } + deriving (Show, Eq) +data PostPicked = PostPicked + { id :: UUID, + authorId :: Picked UUID, + title :: Picked Text, + status :: Picked PostStatus + } + deriving (Show, Eq) +postSelect :: PostSelect +postSelect = + PostSelect + { id = False, + authorId = False, + title = False, + status = False + } +postSelectColumns :: PostSelect -> [Text] +postSelectColumns select_ = + fieldColumn postId + : concat + [ [fieldColumn postAuthorId | select_.authorId] + , [fieldColumn postTitle | select_.title] + , [fieldColumn postStatus | select_.status] + ] +parsePostPicked :: PostSelect -> RowParser PostPicked +parsePostPicked select_ = do + idVal <- field + authorIdVal <- if select_.authorId then Picked <$> field else pure Skipped + titleVal <- if select_.title then Picked <$> field else pure Skipped + statusVal <- if select_.status then Picked <$> field else pure Skipped + pure PostPicked { id = idVal, authorId = authorIdVal, title = titleVal, status = statusVal } +toPostPicked :: PostSelect -> PostRow -> PostPicked +toPostPicked select_ row = + PostPicked + { id = row.id, + authorId = picked select_.authorId row.authorId, + title = picked select_.title row.title, + status = picked select_.status row.status + } + + +postId :: Field PostTable UUID +postId = Field "id" "id" + +postAuthorId :: Field PostTable UUID +postAuthorId = Field "authorId" "author_id" + +postTitle :: Field PostTable Text +postTitle = Field "title" "title" + +postStatus :: Field PostTable PostStatus +postStatus = Field "status" "status" + diff --git a/test/Schema/PostStatus.hs b/test/Schema/PostStatus.hs new file mode 100644 --- /dev/null +++ b/test/Schema/PostStatus.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Schema.PostStatus + ( PostStatus (..), + postStatusToString + ) +where + +import Data.Maybe (isNothing) +import Data.Text (Text) +import Poppy.Internal.Generated + ( FromField (..), + ResultError (ConversionFailed, UnexpectedNull), + returnError, + ToField (..), + toField, + ) + +data PostStatus = Draft | Published + deriving (Show, Eq) + + +instance FromField PostStatus where + fromField f bs + | isNothing bs = returnError UnexpectedNull f "" + | bs == Just "draft" = pure Draft + | bs == Just "published" = pure Published + | otherwise = returnError ConversionFailed f "" + + +instance ToField PostStatus where + toField = toField . postStatusToString + + +postStatusToString :: PostStatus -> Text +postStatusToString Draft = "draft" +postStatusToString Published = "published" + diff --git a/test/Schema/Section.hs b/test/Schema/Section.hs new file mode 100644 --- /dev/null +++ b/test/Schema/Section.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NoFieldSelectors #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE TypeApplications #-} + +module Schema.Section + ( SectionTable (..), + SectionRow (..), + SectionSelect (..), + SectionPicked (..), + sectionSelect, + sectionSelectColumns, + parseSectionPicked, + toSectionPicked, + SectionCreate (..), + SectionUpdate (..), + sectionId, + sectionChapterRef, + sectionLabel + ) +where + +import Data.Text (Text) +import Data.UUID (UUID) +import Poppy.Internal.Generated + ( FromRow (..), + RowParser, + field, + Entity (..), + Field (..), + PrimaryKeyType, + ModelTable, + Picked (..), + picked, + Insertable (..), + emptyInsert, + set, + setMaybe, + Updatable (..), + emptyUpdate, + setFieldMaybe + ) + +data SectionTable = SectionTable + +type instance PrimaryKeyType SectionTable = UUID + +type instance ModelTable "Section" = SectionTable + +instance Entity SectionTable where + tableName = "test_section" + primaryKey = sectionId + tableColumns = ["id", "chapter_id", "label"] + +instance Insertable SectionTable where + type CreateInput SectionTable = SectionCreate + toInsertBuilder input = + setMaybe sectionId input.id $ + set sectionChapterRef input.chapterRef $ + set sectionLabel input.label $ + emptyInsert @SectionTable + + +instance Updatable SectionTable where + type UpdateInput SectionTable = SectionUpdate + updatedAtField = Nothing + toUpdateBuilder input = + setFieldMaybe sectionChapterRef input.chapterRef $ + setFieldMaybe sectionLabel input.label $ + emptyUpdate @SectionTable + + +data SectionRow = SectionRow + { id :: UUID, + chapterRef :: UUID, + label :: Text + } + deriving (Show, Eq) + + +data SectionCreate = SectionCreate + { id :: Maybe UUID, + chapterRef :: UUID, + label :: Text + } + deriving (Show, Eq) + + +data SectionUpdate = SectionUpdate + { chapterRef :: Maybe UUID, + label :: Maybe Text + } + deriving (Show, Eq) + + +instance FromRow SectionRow where + fromRow = SectionRow <$> field <*> field <*> field + + +data SectionSelect = SectionSelect + { id :: Bool, + chapterRef :: Bool, + label :: Bool + } + deriving (Show, Eq) +data SectionPicked = SectionPicked + { id :: UUID, + chapterRef :: Picked UUID, + label :: Picked Text + } + deriving (Show, Eq) +sectionSelect :: SectionSelect +sectionSelect = + SectionSelect + { id = False, + chapterRef = False, + label = False + } +sectionSelectColumns :: SectionSelect -> [Text] +sectionSelectColumns select_ = + fieldColumn sectionId + : concat + [ [fieldColumn sectionChapterRef | select_.chapterRef] + , [fieldColumn sectionLabel | select_.label] + ] +parseSectionPicked :: SectionSelect -> RowParser SectionPicked +parseSectionPicked select_ = do + idVal <- field + chapterRefVal <- if select_.chapterRef then Picked <$> field else pure Skipped + labelVal <- if select_.label then Picked <$> field else pure Skipped + pure SectionPicked { id = idVal, chapterRef = chapterRefVal, label = labelVal } +toSectionPicked :: SectionSelect -> SectionRow -> SectionPicked +toSectionPicked select_ row = + SectionPicked + { id = row.id, + chapterRef = picked select_.chapterRef row.chapterRef, + label = picked select_.label row.label + } + + +sectionId :: Field SectionTable UUID +sectionId = Field "id" "id" + +sectionChapterRef :: Field SectionTable UUID +sectionChapterRef = Field "chapterRef" "chapter_id" + +sectionLabel :: Field SectionTable Text +sectionLabel = Field "label" "label" + diff --git a/test/Schema/Shelf.hs b/test/Schema/Shelf.hs new file mode 100644 --- /dev/null +++ b/test/Schema/Shelf.hs @@ -0,0 +1,136 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NoFieldSelectors #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE TypeApplications #-} + +module Schema.Shelf + ( ShelfTable (..), + ShelfRow (..), + ShelfSelect (..), + ShelfPicked (..), + shelfSelect, + shelfSelectColumns, + parseShelfPicked, + toShelfPicked, + ShelfCreate (..), + ShelfUpdate (..), + shelfId, + shelfName + ) +where + +import Data.Text (Text) +import Data.UUID (UUID) +import Poppy.Internal.Generated + ( FromRow (..), + RowParser, + field, + Entity (..), + Field (..), + PrimaryKeyType, + ModelTable, + Picked (..), + picked, + Insertable (..), + emptyInsert, + set, + setMaybe, + Updatable (..), + emptyUpdate, + setFieldMaybe + ) + +data ShelfTable = ShelfTable + +type instance PrimaryKeyType ShelfTable = UUID + +type instance ModelTable "Shelf" = ShelfTable + +instance Entity ShelfTable where + tableName = "test_shelf" + primaryKey = shelfId + tableColumns = ["id", "name"] + +instance Insertable ShelfTable where + type CreateInput ShelfTable = ShelfCreate + toInsertBuilder input = + setMaybe shelfId input.id $ + set shelfName input.name $ + emptyInsert @ShelfTable + + +instance Updatable ShelfTable where + type UpdateInput ShelfTable = ShelfUpdate + updatedAtField = Nothing + toUpdateBuilder input = + setFieldMaybe shelfName input.name $ + emptyUpdate @ShelfTable + + +data ShelfRow = ShelfRow + { id :: UUID, + name :: Text + } + deriving (Show, Eq) + + +data ShelfCreate = ShelfCreate + { id :: Maybe UUID, + name :: Text + } + deriving (Show, Eq) + + +data ShelfUpdate = ShelfUpdate + { name :: Maybe Text + } + deriving (Show, Eq) + + +instance FromRow ShelfRow where + fromRow = ShelfRow <$> field <*> field + + +data ShelfSelect = ShelfSelect + { id :: Bool, + name :: Bool + } + deriving (Show, Eq) +data ShelfPicked = ShelfPicked + { id :: UUID, + name :: Picked Text + } + deriving (Show, Eq) +shelfSelect :: ShelfSelect +shelfSelect = + ShelfSelect + { id = False, + name = False + } +shelfSelectColumns :: ShelfSelect -> [Text] +shelfSelectColumns select_ = + fieldColumn shelfId + : concat + [ [fieldColumn shelfName | select_.name] + ] +parseShelfPicked :: ShelfSelect -> RowParser ShelfPicked +parseShelfPicked select_ = do + idVal <- field + nameVal <- if select_.name then Picked <$> field else pure Skipped + pure ShelfPicked { id = idVal, name = nameVal } +toShelfPicked :: ShelfSelect -> ShelfRow -> ShelfPicked +toShelfPicked select_ row = + ShelfPicked + { id = row.id, + name = picked select_.name row.name + } + + +shelfId :: Field ShelfTable UUID +shelfId = Field "id" "id" + +shelfName :: Field ShelfTable Text +shelfName = Field "name" "name" + diff --git a/test/Schema/Tag.hs b/test/Schema/Tag.hs new file mode 100644 --- /dev/null +++ b/test/Schema/Tag.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NoFieldSelectors #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE TypeApplications #-} + +module Schema.Tag + ( TagTable (..), + TagRow (..), + TagSelect (..), + TagPicked (..), + tagSelect, + tagSelectColumns, + parseTagPicked, + toTagPicked, + TagCreate (..), + TagUpdate (..), + tagId, + tagShelfId, + tagLabel + ) +where + +import Data.Text (Text) +import Data.UUID (UUID) +import Poppy.Internal.Generated + ( FromRow (..), + RowParser, + field, + Entity (..), + Field (..), + PrimaryKeyType, + ModelTable, + Picked (..), + picked, + Insertable (..), + emptyInsert, + set, + setMaybe, + Updatable (..), + emptyUpdate, + setFieldMaybe + ) + +data TagTable = TagTable + +type instance PrimaryKeyType TagTable = UUID + +type instance ModelTable "Tag" = TagTable + +instance Entity TagTable where + tableName = "test_tag" + primaryKey = tagId + tableColumns = ["id", "shelf_id", "label"] + +instance Insertable TagTable where + type CreateInput TagTable = TagCreate + toInsertBuilder input = + setMaybe tagId input.id $ + set tagShelfId input.shelfId $ + set tagLabel input.label $ + emptyInsert @TagTable + + +instance Updatable TagTable where + type UpdateInput TagTable = TagUpdate + updatedAtField = Nothing + toUpdateBuilder input = + setFieldMaybe tagShelfId input.shelfId $ + setFieldMaybe tagLabel input.label $ + emptyUpdate @TagTable + + +data TagRow = TagRow + { id :: UUID, + shelfId :: UUID, + label :: Text + } + deriving (Show, Eq) + + +data TagCreate = TagCreate + { id :: Maybe UUID, + shelfId :: UUID, + label :: Text + } + deriving (Show, Eq) + + +data TagUpdate = TagUpdate + { shelfId :: Maybe UUID, + label :: Maybe Text + } + deriving (Show, Eq) + + +instance FromRow TagRow where + fromRow = TagRow <$> field <*> field <*> field + + +data TagSelect = TagSelect + { id :: Bool, + shelfId :: Bool, + label :: Bool + } + deriving (Show, Eq) +data TagPicked = TagPicked + { id :: UUID, + shelfId :: Picked UUID, + label :: Picked Text + } + deriving (Show, Eq) +tagSelect :: TagSelect +tagSelect = + TagSelect + { id = False, + shelfId = False, + label = False + } +tagSelectColumns :: TagSelect -> [Text] +tagSelectColumns select_ = + fieldColumn tagId + : concat + [ [fieldColumn tagShelfId | select_.shelfId] + , [fieldColumn tagLabel | select_.label] + ] +parseTagPicked :: TagSelect -> RowParser TagPicked +parseTagPicked select_ = do + idVal <- field + shelfIdVal <- if select_.shelfId then Picked <$> field else pure Skipped + labelVal <- if select_.label then Picked <$> field else pure Skipped + pure TagPicked { id = idVal, shelfId = shelfIdVal, label = labelVal } +toTagPicked :: TagSelect -> TagRow -> TagPicked +toTagPicked select_ row = + TagPicked + { id = row.id, + shelfId = picked select_.shelfId row.shelfId, + label = picked select_.label row.label + } + + +tagId :: Field TagTable UUID +tagId = Field "id" "id" + +tagShelfId :: Field TagTable UUID +tagShelfId = Field "shelfId" "shelf_id" + +tagLabel :: Field TagTable Text +tagLabel = Field "label" "label" + diff --git a/test/Schema/Widget.hs b/test/Schema/Widget.hs new file mode 100644 --- /dev/null +++ b/test/Schema/Widget.hs @@ -0,0 +1,186 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NoFieldSelectors #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE TypeApplications #-} + +module Schema.Widget + ( WidgetTable (..), + WidgetRow (..), + WidgetSelect (..), + WidgetPicked (..), + widgetSelect, + widgetSelectColumns, + parseWidgetPicked, + toWidgetPicked, + WidgetCreate (..), + WidgetUpdate (..), + widgetId, + widgetCreatedAt, + widgetUpdatedAt, + widgetName, + widgetDescription + ) +where + +import Data.Text (Text) +import Data.Time (UTCTime) +import Data.UUID (UUID) +import Poppy.Internal.Generated + ( FromRow (..), + RowParser, + field, + Entity (..), + Field (..), + PrimaryKeyType, + ModelTable, + Picked (..), + picked, + Insertable (..), + emptyInsert, + NullableValue (..), + set, + setMaybe, + setNullable, + Updatable (..), + emptyUpdate, + setFieldMaybe, + setFieldNullable + ) + +data WidgetTable = WidgetTable + +type instance PrimaryKeyType WidgetTable = UUID + +type instance ModelTable "Widget" = WidgetTable + +instance Entity WidgetTable where + tableName = "test_widget" + primaryKey = widgetId + tableColumns = ["id", "created_at", "updated_at", "name", "description"] + uniqueKeys = [["id"], ["name"]] + +instance Insertable WidgetTable where + type CreateInput WidgetTable = WidgetCreate + toInsertBuilder input = + setMaybe widgetId input.id $ + setMaybe widgetCreatedAt input.createdAt $ + setMaybe widgetUpdatedAt input.updatedAt $ + set widgetName input.name $ + setNullable widgetDescription input.description $ + emptyInsert @WidgetTable + + +instance Updatable WidgetTable where + type UpdateInput WidgetTable = WidgetUpdate + updatedAtField = Just widgetUpdatedAt + toUpdateBuilder input = + setFieldMaybe widgetCreatedAt input.createdAt $ + setFieldMaybe widgetUpdatedAt input.updatedAt $ + setFieldMaybe widgetName input.name $ + setFieldNullable widgetDescription input.description $ + emptyUpdate @WidgetTable + + +data WidgetRow = WidgetRow + { id :: UUID, + createdAt :: UTCTime, + updatedAt :: UTCTime, + name :: Text, + description :: Maybe Text + } + deriving (Show, Eq) + + +data WidgetCreate = WidgetCreate + { id :: Maybe UUID, + createdAt :: Maybe UTCTime, + updatedAt :: Maybe UTCTime, + name :: Text, + description :: NullableValue Text + } + deriving (Show, Eq) + + +data WidgetUpdate = WidgetUpdate + { createdAt :: Maybe UTCTime, + updatedAt :: Maybe UTCTime, + name :: Maybe Text, + description :: NullableValue Text + } + deriving (Show, Eq) + + +instance FromRow WidgetRow where + fromRow = WidgetRow <$> field <*> field <*> field <*> field <*> field + + +data WidgetSelect = WidgetSelect + { id :: Bool, + createdAt :: Bool, + updatedAt :: Bool, + name :: Bool, + description :: Bool + } + deriving (Show, Eq) +data WidgetPicked = WidgetPicked + { id :: UUID, + createdAt :: Picked UTCTime, + updatedAt :: Picked UTCTime, + name :: Picked Text, + description :: Picked (Maybe Text) + } + deriving (Show, Eq) +widgetSelect :: WidgetSelect +widgetSelect = + WidgetSelect + { id = False, + createdAt = False, + updatedAt = False, + name = False, + description = False + } +widgetSelectColumns :: WidgetSelect -> [Text] +widgetSelectColumns select_ = + fieldColumn widgetId + : concat + [ [fieldColumn widgetCreatedAt | select_.createdAt] + , [fieldColumn widgetUpdatedAt | select_.updatedAt] + , [fieldColumn widgetName | select_.name] + , [fieldColumn widgetDescription | select_.description] + ] +parseWidgetPicked :: WidgetSelect -> RowParser WidgetPicked +parseWidgetPicked select_ = do + idVal <- field + createdAtVal <- if select_.createdAt then Picked <$> field else pure Skipped + updatedAtVal <- if select_.updatedAt then Picked <$> field else pure Skipped + nameVal <- if select_.name then Picked <$> field else pure Skipped + descriptionVal <- if select_.description then Picked <$> field else pure Skipped + pure WidgetPicked { id = idVal, createdAt = createdAtVal, updatedAt = updatedAtVal, name = nameVal, description = descriptionVal } +toWidgetPicked :: WidgetSelect -> WidgetRow -> WidgetPicked +toWidgetPicked select_ row = + WidgetPicked + { id = row.id, + createdAt = picked select_.createdAt row.createdAt, + updatedAt = picked select_.updatedAt row.updatedAt, + name = picked select_.name row.name, + description = picked select_.description row.description + } + + +widgetId :: Field WidgetTable UUID +widgetId = Field "id" "id" + +widgetCreatedAt :: Field WidgetTable UTCTime +widgetCreatedAt = Field "createdAt" "created_at" + +widgetUpdatedAt :: Field WidgetTable UTCTime +widgetUpdatedAt = Field "updatedAt" "updated_at" + +widgetName :: Field WidgetTable Text +widgetName = Field "name" "name" + +widgetDescription :: Field WidgetTable Text +widgetDescription = Field "description" "description" + diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,42 @@ +module Main (main) where + +import Poppy.BelongsToSpec (belongsToSpec) +import Poppy.ClientWriteSpec (clientWriteSpec) +import Poppy.CommentSpec (commentSpec) +import Poppy.DbSpec (dbSpec) +import Poppy.EnumSpec (enumSpec) +import Poppy.ErrorsSpec (errorsSpec) +import Poppy.GroupSpec (groupSpec) +import Poppy.IncludeFailSpec (includeFailSpec) +import Poppy.IncludeSpec (includeSpec) +import Poppy.MigrateSpec (migrateSpec) +import Poppy.NestedWriteSpec (nestedWriteSpec) +import Poppy.OperationsSpec (operationsSpec) +import Poppy.RawSpec (rawSpec) +import Poppy.ScalarSpec (scalarSpec) +import Poppy.SelectSpec (selectSpec) +import Poppy.UniqueFailSpec (uniqueFailSpec) +import Poppy.WhereSpec (whereSpec) +import Support.TestDb (withTestDb) +import Test.Hspec + +main :: IO () +main = hspec $ do + includeFailSpec + uniqueFailSpec + errorsSpec + groupSpec + whereSpec + withTestDb $ + operationsSpec + >> includeSpec + >> commentSpec + >> belongsToSpec + >> enumSpec + >> rawSpec + >> selectSpec + >> nestedWriteSpec + >> dbSpec + >> migrateSpec + >> clientWriteSpec + >> scalarSpec diff --git a/test/Support/Assert.hs b/test/Support/Assert.hs new file mode 100644 --- /dev/null +++ b/test/Support/Assert.hs @@ -0,0 +1,13 @@ +module Support.Assert + ( assertRight, + assertJust, + ) +where + +assertRight :: Show e => Either e a -> IO a +assertRight (Left err) = fail (show err) +assertRight (Right x) = pure x + +assertJust :: Maybe a -> IO a +assertJust Nothing = fail "expected Just" +assertJust (Just x) = pure x diff --git a/test/Support/TestDb.hs b/test/Support/TestDb.hs new file mode 100644 --- /dev/null +++ b/test/Support/TestDb.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Support.TestDb + ( TestEnv (..), + withTestDb, + testDatabaseUrl, + resetTestData, + truncateTable, + ) +where + +import Control.Exception (SomeException, displayException, try) +import Control.Monad (void) +import Data.Text (Text) +import qualified Data.Text.Encoding as TE +import qualified Database.PostgreSQL.Simple as PG +import Database.PostgreSQL.Simple.Types (Query (..)) +import Poppy.Internal.Core (Entity (..)) +import Poppy.Internal.Db (DbPool, closePool, connect, withConn) +import Poppy.Internal.Sql (quoteIdent) +import Schema.Author (AuthorTable) +import Schema.Book (BookTable) +import Schema.Chapter (ChapterTable) +import Schema.Comment (CommentTable) +import Schema.Packet (PacketTable) +import Schema.Post (PostTable) +import Schema.Section (SectionTable) +import Schema.Shelf (ShelfTable) +import Schema.Tag (TagTable) +import Schema.Widget (WidgetTable) +import Support.TestMigrations (runTestMigrations) +import System.Environment (lookupEnv) +import Test.Hspec (Spec, SpecWith, afterAll, beforeAll, beforeWith) + +newtype TestEnv = TestEnv + { envPool :: DbPool + } + +withTestDb :: SpecWith TestEnv -> Spec +withTestDb spec = + beforeAll setupTestEnv $ + afterAll destroyTestEnv $ + beforeWith (\env -> resetTestData env >> return env) spec + +testDatabaseUrl :: IO String +testDatabaseUrl = do + mTestUrl <- lookupEnv "TEST_DATABASE_URL" + case mTestUrl of + Nothing -> + fail $ + unlines + [ "No test database URL configured.", + "Set TEST_DATABASE_URL.", + "Start Postgres with: docker compose up -d", + "Default URL: postgres://poppy:poppy@127.0.0.1:5435/poppy_test" + ] + Just url -> return url + +setupTestEnv :: IO TestEnv +setupTestEnv = do + databaseUrl <- testDatabaseUrl + result <- try @SomeException $ do + runTestMigrations databaseUrl + connect databaseUrl + case result of + Left err -> fail (connectionErrorMessage databaseUrl err) + Right pool -> return TestEnv {envPool = pool} + +connectionErrorMessage :: String -> SomeException -> String +connectionErrorMessage databaseUrl err = + unlines + [ "Could not connect to the test database.", + displayException err, + "", + "URL: " <> databaseUrl, + "", + "Start the test database with:", + " docker compose up -d", + "", + "Then:", + " TEST_DATABASE_URL=postgres://poppy:poppy@127.0.0.1:5435/poppy_test cabal test all" + ] + +destroyTestEnv :: TestEnv -> IO () +destroyTestEnv TestEnv {envPool = pool} = + closePool pool + +resetTestData :: TestEnv -> IO () +resetTestData env = do + truncateTable @WidgetTable env + truncateTable @SectionTable env + truncateTable @ChapterTable env + truncateTable @BookTable env + truncateTable @TagTable env + truncateTable @ShelfTable env + truncateTable @PostTable env + truncateTable @AuthorTable env + truncateTable @CommentTable env + truncateTable @PacketTable env + +truncateTable :: + forall table. + (Entity table) => + TestEnv -> + IO () +truncateTable TestEnv {envPool = pool} = + withConn pool $ \conn -> + void $ + PG.execute_ + conn + (Query (TE.encodeUtf8 ("TRUNCATE " <> quoteIdent (tableName @table) <> " RESTART IDENTITY CASCADE" :: Text))) diff --git a/test/Support/TestMigrations.hs b/test/Support/TestMigrations.hs new file mode 100644 --- /dev/null +++ b/test/Support/TestMigrations.hs @@ -0,0 +1,44 @@ +module Support.TestMigrations + ( runTestMigrations, + ) +where + +import Control.Exception (Handler (..), catches, throwIO) +import Control.Monad (forM_, void) +import qualified Data.ByteString.Char8 as B8 +import Data.Char (isSpace) +import Data.List (sort) +import Database.PostgreSQL.Simple (Connection, SqlError (..), connectPostgreSQL, execute_) +import Database.PostgreSQL.Simple.Types (Query (..)) +import System.Directory (listDirectory) +import System.FilePath (()) + +testMigrationsDir :: FilePath +testMigrationsDir = "test/migrations" + +runTestMigrations :: String -> IO () +runTestMigrations databaseUrl = do + conn <- connectPostgreSQL $ B8.pack databaseUrl + names <- sort <$> listDirectory testMigrationsDir + forM_ names $ \name -> do + sql <- B8.readFile (testMigrationsDir name) + forM_ (splitStatements sql) $ \stmt -> + executeIgnoringDuplicate conn stmt + +splitStatements :: B8.ByteString -> [B8.ByteString] +splitStatements = + filter (not . B8.null) . map stripBytes . B8.split ';' + +executeIgnoringDuplicate :: Connection -> B8.ByteString -> IO () +executeIgnoringDuplicate conn stmt = + void (execute_ conn (Query stmt)) + `catches` [Handler ignoreDuplicate] + where + ignoreDuplicate err + | sqlState err == "42710" = pure () + | sqlState err == "42P07" = pure () -- relation already exists (replayed UNIQUE) + | otherwise = throwIO err + +stripBytes :: B8.ByteString -> B8.ByteString +stripBytes = + B8.reverse . B8.dropWhile isSpace . B8.reverse . B8.dropWhile isSpace diff --git a/test/migrations/001-test-widget.sql b/test/migrations/001-test-widget.sql new file mode 100644 --- /dev/null +++ b/test/migrations/001-test-widget.sql @@ -0,0 +1,9 @@ +CREATE EXTENSION IF NOT EXISTS "uuid-ossp"; + +CREATE TABLE IF NOT EXISTS test_widget ( + id UUID NOT NULL DEFAULT uuid_generate_v4() PRIMARY KEY, + created_at TIMESTAMPTZ(6) NOT NULL DEFAULT CURRENT_TIMESTAMP, + updated_at TIMESTAMPTZ(6) NOT NULL DEFAULT CURRENT_TIMESTAMP, + name TEXT NOT NULL, + description TEXT +); diff --git a/test/migrations/002-test-shelf-book.sql b/test/migrations/002-test-shelf-book.sql new file mode 100644 --- /dev/null +++ b/test/migrations/002-test-shelf-book.sql @@ -0,0 +1,10 @@ +CREATE TABLE IF NOT EXISTS test_shelf ( + id UUID NOT NULL DEFAULT uuid_generate_v4() PRIMARY KEY, + name TEXT NOT NULL +); + +CREATE TABLE IF NOT EXISTS test_book ( + id UUID NOT NULL DEFAULT uuid_generate_v4() PRIMARY KEY, + shelf_id UUID NOT NULL REFERENCES test_shelf (id), + title TEXT NOT NULL +); diff --git a/test/migrations/003-test-chapter.sql b/test/migrations/003-test-chapter.sql new file mode 100644 --- /dev/null +++ b/test/migrations/003-test-chapter.sql @@ -0,0 +1,5 @@ +CREATE TABLE IF NOT EXISTS test_chapter ( + id UUID NOT NULL DEFAULT uuid_generate_v4() PRIMARY KEY, + book_id UUID NOT NULL REFERENCES test_book (id) ON DELETE CASCADE, + heading TEXT NOT NULL +); diff --git a/test/migrations/004-test-section.sql b/test/migrations/004-test-section.sql new file mode 100644 --- /dev/null +++ b/test/migrations/004-test-section.sql @@ -0,0 +1,5 @@ +CREATE TABLE IF NOT EXISTS test_section ( + id UUID NOT NULL DEFAULT uuid_generate_v4() PRIMARY KEY, + chapter_id UUID NOT NULL REFERENCES test_chapter (id) ON DELETE CASCADE, + label TEXT NOT NULL +); diff --git a/test/migrations/005-test-tag.sql b/test/migrations/005-test-tag.sql new file mode 100644 --- /dev/null +++ b/test/migrations/005-test-tag.sql @@ -0,0 +1,5 @@ +CREATE TABLE IF NOT EXISTS test_tag ( + id UUID NOT NULL DEFAULT uuid_generate_v4() PRIMARY KEY, + shelf_id UUID NOT NULL REFERENCES test_shelf (id), + label TEXT NOT NULL +); diff --git a/test/migrations/006-test-author-post.sql b/test/migrations/006-test-author-post.sql new file mode 100644 --- /dev/null +++ b/test/migrations/006-test-author-post.sql @@ -0,0 +1,13 @@ +CREATE TYPE poststatus AS ENUM ('draft', 'published'); + +CREATE TABLE IF NOT EXISTS test_author ( + id UUID NOT NULL DEFAULT uuid_generate_v4() PRIMARY KEY, + name TEXT NOT NULL +); + +CREATE TABLE IF NOT EXISTS test_post ( + id UUID NOT NULL DEFAULT uuid_generate_v4() PRIMARY KEY, + author_id UUID NOT NULL REFERENCES test_author (id), + title TEXT NOT NULL, + status poststatus NOT NULL +); diff --git a/test/migrations/007-test-packet.sql b/test/migrations/007-test-packet.sql new file mode 100644 --- /dev/null +++ b/test/migrations/007-test-packet.sql @@ -0,0 +1,5 @@ +CREATE TABLE IF NOT EXISTS test_packet ( + id UUID NOT NULL DEFAULT uuid_generate_v4() PRIMARY KEY, + amount NUMERIC NOT NULL, + payload JSONB NOT NULL +); diff --git a/test/migrations/008-test-comment.sql b/test/migrations/008-test-comment.sql new file mode 100644 --- /dev/null +++ b/test/migrations/008-test-comment.sql @@ -0,0 +1,5 @@ +CREATE TABLE IF NOT EXISTS test_comment ( + id UUID NOT NULL DEFAULT uuid_generate_v4() PRIMARY KEY, + parent_id UUID REFERENCES test_comment (id), + body TEXT NOT NULL +); diff --git a/test/migrations/009-test-widget-name-unique.sql b/test/migrations/009-test-widget-name-unique.sql new file mode 100644 --- /dev/null +++ b/test/migrations/009-test-widget-name-unique.sql @@ -0,0 +1,1 @@ +ALTER TABLE test_widget ADD CONSTRAINT test_widget_name_key UNIQUE (name); diff --git a/unique-fail/NonUniqueFilter.hs b/unique-fail/NonUniqueFilter.hs new file mode 100644 --- /dev/null +++ b/unique-fail/NonUniqueFilter.hs @@ -0,0 +1,9 @@ +module NonUniqueFilter where + +import Poppy (eq) +import qualified Schema.Client.Widget as Widget +import Schema.Widget (widgetName) + +bad = + Widget.findUnique + Widget.emptyQuery {Widget.where_ = Just (eq widgetName "sage")}