diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,32 @@ +# Changelog + +All notable changes to `poppy-codegen` 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` (`poppy >= 1.0 && < 1.1` for this release). +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 Schema builder, Client emission, `--check`, and `--check-schema`. + +- Only `Poppy.Codegen.Schema` and `Poppy.Codegen.CLI` are exposed. `Schema`, `Model`, + `FieldSpec`, and `RelationSpec` are abstract. Generated modules import + `Poppy.Internal.Generated`. +- Haddock on the public modules. Guides: repository `docs/`. +- `--check-schema` reads `DATABASE_URL` only. Pass `--database-url URL` to override it. +- Model modules no longer emit `HasMany` / `BelongsTo` values. +- Include and nested-write fields use the relation name. Models with relations emit + `Schema.Include.` (`skip` / `load` / `loadWith`, with edge `where_` / + `orderBy_` / `take_`). +- Clients emit `Unique` / `UniqueKey`. Nested writes live on `create` / + `update` relation fields. +- Nested-write Clients import root scalar types required by re-emitted create/update + payloads (`UTCTime`, `NullableValue`, …). + +## 0.1.0.0 — 2026-09-17 + +First release. Schema builder, `generate` Client emission, `--check` freshness, and `--check-schema` drift against live Postgres. 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,28 @@ +# poppy-codegen + +The code generator for [Poppy](https://github.com/hnerdrum/poppy), a Postgres ORM for Haskell. You describe tables with `Poppy.Codegen.Schema`, then call `generate` from an executable to write table types and a client for the [`poppy`](https://github.com/hnerdrum/poppy/tree/main/poppy) runtime. + +```haskell +module Main (main) where + +import Poppy.Codegen.CLI (generate) +import TaskSchema (taskSchema) + +main :: IO () +main = generate "src/Schema" taskSchema +``` + +`generate` takes an output directory and the schema value. The directory sets the module prefix, so `src/Schema` produces modules under `Schema`, with the clients in `src/Schema/Client`. + +The executable accepts the following flags: + +| Flag | Purpose | +| ---------------- | --------------------------------------------------- | +| _(none)_ | Validate Schemas and write generated files | +| `--check` | Fail if generated files on disk differ from Codegen | +| `--check-schema` | Compare Schema to live Postgres database | +| `--list` | Print output paths without writing | + +`--check-schema` reads `DATABASE_URL`. Pass `--database-url URL` to override it. The check fails if tables, columns, or keys do not match the schema. + +The [repository README](https://github.com/hnerdrum/poppy#readme) shows the full setup. For working code, see [`examples/task/`](https://github.com/hnerdrum/poppy/tree/main/examples/task) and [`examples/blog/`](https://github.com/hnerdrum/poppy/tree/main/examples/blog). The [guides](https://github.com/hnerdrum/poppy/tree/main/docs) cover the schema builder and migrations in more depth. diff --git a/poppy-codegen.cabal b/poppy-codegen.cabal new file mode 100644 --- /dev/null +++ b/poppy-codegen.cabal @@ -0,0 +1,154 @@ +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-codegen +version: 1.0.0 +synopsis: Schema builder and Client codegen for Poppy +description: Write a Schema, generate table types and a Client, and compare that + Schema to live 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/009-test-widget-name-unique.sql + test/Poppy/Codegen/golden/Article.hs.golden + test/Poppy/Codegen/golden/Author.hs.golden + test/Poppy/Codegen/golden/Book.hs.golden + test/Poppy/Codegen/golden/Chapter.hs.golden + test/Poppy/Codegen/golden/Comment.hs.golden + test/Poppy/Codegen/golden/Editor.hs.golden + test/Poppy/Codegen/golden/Flag.hs.golden + test/Poppy/Codegen/golden/Packet.hs.golden + test/Poppy/Codegen/golden/Post.hs.golden + test/Poppy/Codegen/golden/PostStatus.hs.golden + test/Poppy/Codegen/golden/Section.hs.golden + test/Poppy/Codegen/golden/Shelf.hs.golden + test/Poppy/Codegen/golden/ShelfReadClient.hs.golden + test/Poppy/Codegen/golden/Tag.hs.golden + test/Poppy/Codegen/golden/Widget.hs.golden +extra-doc-files: + README.md + CHANGELOG.md + +source-repository head + type: git + location: https://github.com/hnerdrum/poppy + +library + exposed-modules: + Poppy.Codegen.CLI + Poppy.Codegen.Schema + other-modules: + Poppy.Codegen.Drift + Poppy.Codegen.Emit.Client + Poppy.Codegen.Emit.Include + Poppy.Codegen.Emit.NestedWrite + Poppy.Codegen.Emit.Schema + Poppy.Codegen.EmitCommon + Poppy.Codegen.IR + Poppy.Codegen.Introspect + Poppy.Codegen.Lookup + Poppy.Codegen.Run + Poppy.Codegen.Target + Poppy.Codegen.TextUtil + Poppy.Codegen.Validate + hs-source-dirs: + src + default-extensions: + NamedFieldPuns + OverloadedRecordDot + OverloadedStrings + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints + build-depends: + base >=4.17 && <4.21 + , containers >=0.6 && <0.8 + , directory ==1.3.* + , filepath >=1.4 && <1.6 + , poppy ==1.0.* + , postgresql-simple >=0.6 && <0.8 + , text >=2.0 && <2.2 + default-language: Haskell2010 + +test-suite poppy-codegen-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Poppy.Codegen.DriftSpec + Poppy.Codegen.EmitClientSpec + Poppy.Codegen.EmitIncludeSpec + Poppy.Codegen.EmitSpec + Poppy.Codegen.SchemaSpec + Poppy.Codegen.Spec.Author + Poppy.Codegen.Spec.Comment + Poppy.Codegen.Spec.Editor + Poppy.Codegen.Spec.Example + Poppy.Codegen.Spec.Flag + Poppy.Codegen.Spec.Packet + Poppy.Codegen.Spec.Shelf + Poppy.Codegen.Spec.ShelfDeep + Poppy.Codegen.Spec.Widget + Poppy.Codegen.TargetSpec + Poppy.Codegen.TestTarget + Poppy.Codegen.ValidateSpec + Support.TestDb + Support.TestMigrations + Poppy.Codegen.CLI + Poppy.Codegen.Drift + Poppy.Codegen.Emit.Client + Poppy.Codegen.Emit.Include + Poppy.Codegen.Emit.NestedWrite + Poppy.Codegen.Emit.Schema + Poppy.Codegen.EmitCommon + Poppy.Codegen.Introspect + Poppy.Codegen.IR + Poppy.Codegen.Lookup + Poppy.Codegen.Run + Poppy.Codegen.Schema + Poppy.Codegen.Target + Poppy.Codegen.TextUtil + Poppy.Codegen.Validate + Paths_poppy_codegen + hs-source-dirs: + test + src + default-extensions: + AllowAmbiguousTypes + NamedFieldPuns + OverloadedRecordDot + OverloadedStrings + TypeApplications + 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: + 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 + , resource-pool ==0.4.* + , text >=2.0 && <2.2 + , time >=1.12 && <1.15 + , uuid ==1.3.* + default-language: Haskell2010 diff --git a/src/Poppy/Codegen/CLI.hs b/src/Poppy/Codegen/CLI.hs new file mode 100644 --- /dev/null +++ b/src/Poppy/Codegen/CLI.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Codegen CLI: write files, @--check@ freshness, @--check-schema@ drift, @--list@ paths. +module Poppy.Codegen.CLI + ( generate, + mainWith, + simpleTarget, + CodegenTarget, + ) +where + +import Data.Text (Text, pack) +import qualified Data.Text.IO as TIO +import Poppy.Codegen.Drift (checkSchema, formatDriftError) +import Poppy.Codegen.IR (Schema) +import Poppy.Codegen.Introspect (introspectCatalog) +import Poppy.Codegen.Run (GenOutput (..), allOutputs, checkOutputs, schemasForTargets, writeOutputs) +import Poppy.Codegen.Target + ( CodegenTarget, + simpleTarget, + targetSchemas, + ) +import Poppy.Codegen.Validate (ValidationError (..), validateSchema) +import Poppy.Internal.Db (closePool, connect, withConn) +import System.Directory (getCurrentDirectory) +import System.Environment (getArgs, lookupEnv) +import System.Exit (exitFailure, exitSuccess) + +-- | Write table types and a Client under @dir@ (@src/Schema@ → module prefix @Schema@). +-- +-- Flags on the process argv: none (write), @--check@, @--check-schema@, @--list@. +-- @--check-schema@ reads @DATABASE_URL@, or the URL passed as @--database-url@. +generate :: FilePath -> Schema -> IO () +generate dir schema = mainWith [simpleTarget dir schema] + +-- | Flags: none (write files), @--check@, @--check-schema@, @--list@. +-- +-- @--check-schema@ may be followed by @--database-url URL@, which overrides +-- @DATABASE_URL@. The two arguments can appear in either order. +mainWith :: [CodegenTarget] -> IO () +mainWith targets = do + root <- getCurrentDirectory + args <- getArgs + case args of + ("--check" : _) -> runCheck root targets + ("--list" : _) -> runList targets + _ | "--check-schema" `elem` args -> do + urlFlag <- checkSchemaDatabaseUrl args + runCheckSchema urlFlag targets + _ -> runWrite root targets + +runWrite :: FilePath -> [CodegenTarget] -> IO () +runWrite root targets = do + validateOrExit (schemasForTargets targets) + writeOutputs root targets + TIO.putStrLn $ "Wrote " <> pack (show (length (allOutputs targets))) <> " generated files." + +runCheck :: FilePath -> [CodegenTarget] -> IO () +runCheck root targets = do + validateOrExit (schemasForTargets targets) + stale <- checkOutputs root targets + case stale of + [] -> exitSuccess + paths -> do + TIO.putStrLn "Generated files are out of date. Re-run codegen without --check." + mapM_ (TIO.putStrLn . (" " <>)) (pack <$> paths) + exitFailure + +runCheckSchema :: Maybe String -> [CodegenTarget] -> IO () +runCheckSchema urlFlag targets = do + let schemas = targetSchemas targets + validateOrExit schemas + url <- schemaDatabaseUrl urlFlag + pool <- connect url + catalog <- withConn pool introspectCatalog + closePool pool + case concatMap (`checkSchema` catalog) schemas of + [] -> exitSuccess + errs -> do + TIO.putStrLn "IR does not match the database. Haskell IR is the source of truth." + mapM_ (TIO.putStrLn . (" " <>) . formatDriftError) errs + exitFailure + +-- | @--database-url@ overrides @DATABASE_URL@. Other arguments besides +-- @--check-schema@ are rejected. +checkSchemaDatabaseUrl :: [String] -> IO (Maybe String) +checkSchemaDatabaseUrl = go Nothing + where + go found [] = pure found + go found ("--check-schema" : rest) = go found rest + go found ("--database-url" : url : rest) + | isOption url = missingUrl + | otherwise = + case found of + Just _ -> do + TIO.putStrLn "--database-url was given more than once." + exitFailure + Nothing -> go (Just url) rest + go _ ("--database-url" : _) = missingUrl + go _ (other : _) = do + TIO.putStrLn $ "Unknown argument: " <> pack other <> "." + TIO.putStrLn "Usage: --check-schema [--database-url URL]" + exitFailure + missingUrl = do + TIO.putStrLn "--database-url requires a URL." + exitFailure + isOption ('-' : '-' : _) = True + isOption _ = False + +schemaDatabaseUrl :: Maybe String -> IO String +schemaDatabaseUrl (Just url) = pure url +schemaDatabaseUrl Nothing = do + mDb <- lookupEnv "DATABASE_URL" + case mDb of + Just url -> pure url + Nothing -> do + TIO.putStrLn "Set DATABASE_URL, or pass --database-url URL, to check the Schema against Postgres." + exitFailure + +runList :: [CodegenTarget] -> IO () +runList targets = mapM_ (TIO.putStrLn . pack . outputPath) (allOutputs targets) + +validateOrExit :: [Schema] -> IO () +validateOrExit schemas = + case concatMap validateSchema schemas of + [] -> pure () + errs -> do + TIO.putStrLn "Schema validation failed:" + mapM_ (TIO.putStrLn . (" " <>) . formatValidationError) errs + exitFailure + +formatValidationError :: ValidationError -> Text +formatValidationError err = pack (show err) diff --git a/src/Poppy/Codegen/Drift.hs b/src/Poppy/Codegen/Drift.hs new file mode 100644 --- /dev/null +++ b/src/Poppy/Codegen/Drift.hs @@ -0,0 +1,336 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Compare a Schema to live Postgres. Poppy does not generate migrations. +module Poppy.Codegen.Drift + ( DbCatalog (..), + DbTable (..), + DbColumn (..), + DbForeignKey (..), + DriftError (..), + emptyCatalog, + checkSchema, + formatDriftError, + ) +where + +import Data.List (find, nub, sort) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Text (Text) +import qualified Data.Text as T +import Poppy.Codegen.IR hiding (field, variant) +import Poppy.Codegen.TextUtil (lowerFirst) + +data DbCatalog = DbCatalog + { dbTables :: Map Text DbTable, + dbEnums :: Map Text [Text], + dbForeignKeys :: [DbForeignKey] + } + deriving (Show, Eq) + +data DbTable = DbTable + { dbTableName :: Text, + dbColumns :: Map Text DbColumn, + dbPrimaryKey :: [Text], + dbUniques :: [Set Text] + } + deriving (Show, Eq) + +data DbColumn = DbColumn + { dbColName :: Text, + dbColType :: Text, + dbColNullable :: Bool, + dbColDefault :: Maybe Text + } + deriving (Show, Eq) + +data DbForeignKey = DbForeignKey + { dbFkFromTable :: Text, + dbFkFromColumn :: Text, + dbFkToTable :: Text, + dbFkToColumn :: Text + } + deriving (Show, Eq) + +data DriftError + = DriftMissingTable Text Text + | DriftMissingColumn Text Text + | DriftExtraColumn Text Text + | DriftNullability Text Text Bool Bool + | DriftType Text Text Text Text + | DriftPrimaryKey Text [Text] [Text] + | DriftMissingUnique Text [Text] + | DriftUnexpectedUnique Text [Text] + | DriftMissingEnum Text Text + | DriftEnumLabels Text [Text] [Text] + | DriftMissingDefault Text Text FieldDefault + | DriftDefaultMismatch Text Text FieldDefault Text + | DriftMissingForeignKey Text Text Text Text + deriving (Show, Eq) + +emptyCatalog :: DbCatalog +emptyCatalog = + DbCatalog + { dbTables = Map.empty, + dbEnums = Map.empty, + dbForeignKeys = [] + } + +checkSchema :: Schema -> DbCatalog -> [DriftError] +checkSchema schema catalog = + concatMap (checkModel catalog) (schemaModels schema) + ++ concatMap (checkEnum catalog) (schemaEnums schema) + ++ concatMap (checkMissingUnique catalog schema) (schemaUniques schema) + ++ concatMap (checkUnexpectedUniques catalog schema) (schemaModels schema) + ++ checkForeignKeys catalog schema + +formatDriftError :: DriftError -> Text +formatDriftError = \case + DriftMissingTable model table -> + "IR model " <> model <> " table " <> table <> " is missing from the database" + DriftMissingColumn table col -> + "IR column " <> table <> "." <> col <> " is missing from the database" + DriftExtraColumn table col -> + "database column " <> table <> "." <> col <> " is not in the IR" + DriftNullability table col irNull dbNull -> + "nullability drift on " + <> table + <> "." + <> col + <> ": IR nullable=" + <> showBool irNull + <> " database nullable=" + <> showBool dbNull + DriftType table col expected actual -> + "type drift on " <> table <> "." <> col <> ": IR " <> expected <> " database " <> actual + DriftPrimaryKey table expected actual -> + "primary key drift on " <> table <> ": IR " <> csv expected <> " database " <> csv actual + DriftMissingUnique table cols -> + "IR unique (" <> csv cols <> ") is missing from " <> table + DriftUnexpectedUnique table cols -> + "database unique (" <> csv cols <> ") on " <> table <> " is not in the IR" + DriftMissingEnum name dbName -> + "IR enum " <> name <> " (database type " <> dbName <> ") is missing" + DriftEnumLabels name expected actual -> + "enum " <> name <> " labels: IR " <> csv expected <> " database " <> csv actual + DriftMissingDefault table col expected -> + "IR column " + <> table + <> "." + <> col + <> " declares DEFAULT " + <> defaultLabel expected + <> " but the database has none" + DriftDefaultMismatch table col expected actual -> + "default drift on " + <> table + <> "." + <> col + <> ": IR " + <> defaultLabel expected + <> " database " + <> actual + DriftMissingForeignKey fromTable fromCol toTable toCol -> + "IR foreign key " + <> fromTable + <> "." + <> fromCol + <> " → " + <> toTable + <> "." + <> toCol + <> " is missing from the database" + +showBool :: Bool -> Text +showBool True = "true" +showBool False = "false" + +csv :: [Text] -> Text +csv = T.intercalate ", " + +checkModel :: DbCatalog -> Model -> [DriftError] +checkModel catalog model = + case Map.lookup (modelTable model) (dbTables catalog) of + Nothing -> + [DriftMissingTable (modelName model) (modelTable model)] + Just table -> + concatMap (checkColumn table) (modelFields model) + ++ extraColumns table (modelFields model) + ++ checkPrimaryKey table model + +checkColumn :: DbTable -> FieldSpec -> [DriftError] +checkColumn table spec = + case Map.lookup (fieldColumn spec) (dbColumns table) of + Nothing -> + [DriftMissingColumn (dbTableName table) (fieldColumn spec)] + Just col -> + [ DriftNullability (dbTableName table) (fieldColumn spec) (fieldNullable spec) (dbColNullable col) + | fieldNullable spec /= dbColNullable col + ] + ++ [ DriftType (dbTableName table) (fieldColumn spec) expected (dbColType col) + | dbColType col /= expected + ] + ++ checkDefault (dbTableName table) (fieldColumn spec) (fieldDefault spec) (dbColDefault col) + where + expected = irType spec + +checkDefault :: Text -> Text -> Maybe FieldDefault -> Maybe Text -> [DriftError] +checkDefault _ _ Nothing _ = [] +checkDefault table col (Just expected) Nothing = + [DriftMissingDefault table col expected] +checkDefault table col (Just expected) (Just actual) = + [ DriftDefaultMismatch table col expected actual + | canonicalizeDefault actual /= Just expected + ] + +canonicalizeDefault :: Text -> Maybe FieldDefault +canonicalizeDefault raw + | mentions ["uuid_generate_v4", "gen_random_uuid"] = Just DefaultUuidV4 + | mentions ["now()", "current_timestamp"] = Just DefaultNow + | otherwise = Nothing + where + normalized = T.toLower (T.strip raw) + mentions = any (`T.isInfixOf` normalized) + +defaultLabel :: FieldDefault -> Text +defaultLabel DefaultUuidV4 = "uuid_generate_v4()" +defaultLabel DefaultNow = "now()" + +extraColumns :: DbTable -> [FieldSpec] -> [DriftError] +extraColumns table fields = + [ DriftExtraColumn (dbTableName table) col + | col <- Map.keys (dbColumns table), + col `notElem` map fieldColumn fields + ] + +checkPrimaryKey :: DbTable -> Model -> [DriftError] +checkPrimaryKey table model = + [ DriftPrimaryKey (modelTable model) expected actual + | expected /= actual + ] + where + expected = map fieldColumn (filter fieldIsPrimaryKey (modelFields model)) + actual = dbPrimaryKey table + +checkMissingUnique :: DbCatalog -> Schema -> UniqueConstraint -> [DriftError] +checkMissingUnique catalog schema UniqueConstraint {uniqueModel, uniqueFields} = + case find ((== uniqueModel) . modelName) (schemaModels schema) of + Nothing -> [] + Just model -> + case Map.lookup (modelTable model) (dbTables catalog) of + Nothing -> [] + Just table -> + let irCols = map (fieldColumnFor model) uniqueFields + irSet = Set.fromList irCols + in [ DriftMissingUnique (modelTable model) (sort irCols) + | irSet `notElem` dbUniques table + ] + +checkUnexpectedUniques :: DbCatalog -> Schema -> Model -> [DriftError] +checkUnexpectedUniques catalog schema model = + case Map.lookup (modelTable model) (dbTables catalog) of + Nothing -> [] + Just table -> + [ DriftUnexpectedUnique (dbTableName table) (sort (Set.toList dbSet)) + | dbSet <- dbUniques table, + dbSet `notElem` irSets + ] + where + irSets = + [ Set.fromList (map (fieldColumnFor model) uniqueFields) + | UniqueConstraint {uniqueModel, uniqueFields} <- schemaUniques schema, + uniqueModel == modelName model + ] + +fieldColumnFor :: Model -> Text -> Text +fieldColumnFor model wanted = + maybe + wanted + fieldColumn + (find ((== wanted) . fieldName) (modelFields model)) + +checkEnum :: DbCatalog -> EnumSpec -> [DriftError] +checkEnum catalog enumSpec = + case Map.lookup dbName (dbEnums catalog) of + Nothing -> + [DriftMissingEnum (enumName enumSpec) dbName] + Just labels -> + [ DriftEnumLabels (enumName enumSpec) expected (sort labels) + | sort labels /= expected + ] + where + dbName = T.toLower (enumName enumSpec) + expected = sort (map variantSqlValue (enumVariants enumSpec)) + +variantSqlValue :: EnumVariant -> Text +variantSqlValue spec = + case variantDbValue spec of + Just value -> value + Nothing -> lowerFirst (variantName spec) + +irType :: FieldSpec -> Text +irType spec = + case fieldType spec of + TyText -> "text" + TyUuid -> "uuid" + TyInt -> "int" + TyNumeric -> "numeric" + TyJsonb -> "jsonb" + TyTimestamptz -> "timestamptz" + TyBool -> "boolean" + TyEnum name -> "enum:" <> T.toLower name + +checkForeignKeys :: DbCatalog -> Schema -> [DriftError] +checkForeignKeys catalog schema = + [ DriftMissingForeignKey fromTable fromCol toTable toCol + | DbForeignKey fromTable fromCol toTable toCol <- impliedForeignKeys schema, + Map.member fromTable (dbTables catalog), + DbForeignKey fromTable fromCol toTable toCol `notElem` dbForeignKeys catalog + ] + +impliedForeignKeys :: Schema -> [DbForeignKey] +impliedForeignKeys schema = + nub + [ fk + | model <- schemaModels schema, + rel <- modelRelations model, + Just fk <- [relationForeignKey schema rel] + ] + +relationForeignKey :: Schema -> RelationSpec -> Maybe DbForeignKey +relationForeignKey schema rel = + case (findModel (relFromModel rel), findModel (relToModel rel)) of + (Just fromModel, Just toModel) -> + Just $ + case relKind rel of + RelHasMany -> + DbForeignKey + { dbFkFromTable = modelTable toModel, + dbFkFromColumn = fieldColumn (lookupNamedField toModel (relForeignField rel)), + dbFkToTable = modelTable fromModel, + dbFkToColumn = fieldColumn (lookupNamedField fromModel (relLocalField rel)) + } + RelBelongsTo -> + DbForeignKey + { dbFkFromTable = modelTable fromModel, + dbFkFromColumn = fieldColumn (lookupNamedField fromModel (relForeignField rel)), + dbFkToTable = modelTable toModel, + dbFkToColumn = fieldColumn (lookupNamedField toModel (relLocalField rel)) + } + _ -> Nothing + where + findModel name = find ((== name) . modelName) (schemaModels schema) + +lookupNamedField :: Model -> Text -> FieldSpec +lookupNamedField model name = + case find ((== name) . fieldName) (modelFields model) of + Just spec -> spec + Nothing -> + error $ + "Poppy.Codegen.Drift: unknown field " + <> T.unpack name + <> " on " + <> T.unpack (modelName model) diff --git a/src/Poppy/Codegen/Emit/Client.hs b/src/Poppy/Codegen/Emit/Client.hs new file mode 100644 --- /dev/null +++ b/src/Poppy/Codegen/Emit/Client.hs @@ -0,0 +1,964 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Poppy.Codegen.Emit.Client + ( emitClientModule, + emitSimpleClientModule, + ) +where + +import Data.List (nub) +import Data.Text (Text) +import qualified Data.Text as T +import Poppy.Codegen.Emit.NestedWrite + ( emitClientCreateManyFn, + emitClientUpsertFn, + emitCreateFn, + emitNestedWriteHelpers, + emitNestedWriteTypes, + emitUpdateFn, + emitUpdateManyFn, + nestedChildClientImports, + nestedChildEnumImports, + nestedChildSchemaImports, + nestedWriteExportItems, + nestedWriteRelations, + nestedWriteUsesTransaction, + schemaModuleAlias, + ) +import Poppy.Codegen.Emit.Schema (enumImportLine) +import Poppy.Codegen.EmitCommon + ( clientSchemaPrefix, + createTypeName, + fieldBinder, + hsType, + parsePickedName, + pickedTypeName, + primaryKeyField, + rowTypeName, + selectColumnsFnName, + selectDefaultName, + selectTypeName, + tableTypeName, + updateTypeName, + ) +import Poppy.Codegen.IR +import Poppy.Codegen.Lookup (lookupField, lookupUniques) +import Poppy.Codegen.TextUtil (lowerFirst, upperFirst) + +emitClientModule :: Text -> Schema -> Model -> Text +emitClientModule moduleName schema model = + if null (modelRelations model) + then emitSimpleClientModule moduleName schema model + else emitIncludeClientModule moduleName schema model + +emitSimpleClientModule :: Text -> Schema -> Model -> Text +emitSimpleClientModule moduleName schema model = + T.unlines + [ "{-# LANGUAGE DuplicateRecordFields #-}", + "{-# LANGUAGE FlexibleContexts #-}", + "{-# LANGUAGE FlexibleInstances #-}", + "{-# LANGUAGE LambdaCase #-}", + "{-# LANGUAGE NamedFieldPuns #-}", + "{-# LANGUAGE RecordWildCards #-}", + "{-# LANGUAGE TypeApplications #-}", + "{-# LANGUAGE TypeFamilies #-}", + "", + "module " <> moduleName, + emitSimpleExports model, + "where", + "", + valueImportsBlock schema moduleName model, + simpleGeneratedImports schema model, + "import " + <> schemaModule moduleName model + <> " (" + <> createTypeName model + <> " (..), " + <> rowTypeName model + <> " (..), " + <> selectTypeName model + <> " (..), " + <> pickedTypeName model + <> " (..), " + <> selectDefaultName model + <> ", " + <> selectColumnsFnName model + <> ", " + <> parsePickedName model + <> ", " + <> tableTypeName model + <> ", " + <> updateTypeName model + <> " (..), " + <> uniqueFieldImportList schema model + <> ")", + "", + emitUniqueDecls schema model, + "", + emitCreateFn schema model, + "", + emitClientCreateManyFn schema model, + "", + emitUpdateFn schema model, + "", + emitUpdateManyFn schema model, + "", + emitClientUpsertFn schema model, + "", + emitQueryType model, + "", + emitUniqueQueryType False model, + "", + emitEmptyQueryFn model, + "", + emitUniqueQueryFn False model, + "", + emitResolveSelect model, + "", + emitFindManyFn model, + "", + emitCountFn model, + "", + emitDeleteFn model, + "", + emitDeleteManyFn model + ] + +emitIncludeClientModule :: Text -> Schema -> Model -> Text +emitIncludeClientModule moduleName schema root = + T.unlines + ( [ "{-# 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 #-}", + "", + emitIncludeClientHeader schema root, + "module " <> moduleName + ] + ++ exportLinesFromItems (includeClientExportItems schema root) + ++ ["where", ""] + ++ includeClientImportLines moduleName schema root + ) + <> "\n" + <> intercalateSections + ( emitUniqueDecls schema root + : filter + (not . T.null) + ( emitNestedWriteTypes schema root + : [ emitCreateFn schema root, + emitClientCreateManyFn schema root, + emitUpdateFn schema root, + emitUpdateManyFn schema root, + emitClientUpsertFn schema root, + emitNestedWriteHelpers schema root + ] + ++ emitIncludeReadDefinitions schema root + ++ [ emitDeleteFn root, + emitDeleteManyFn root + ] + ) + ) + +emitIncludeClientHeader :: Schema -> Model -> Text +emitIncludeClientHeader schema root = + T.intercalate "\n" $ + ["{- | Generated Client. Do not edit."] + ++ nestedDocs + ++ ["-}"] + where + nestedDocs = + case nestedWriteRelations schema root of + [] -> [] + _ -> + [ "", + "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)" + ] + +emitSimpleExports :: Model -> Text +emitSimpleExports model = + T.unlines + [ " ( create,", + " createMany,", + " update,", + " updateMany,", + " upsert,", + " findMany,", + " findUnique,", + " findUniqueOrFail,", + " findFirst,", + " findFirstOrFail,", + " count,", + " delete,", + " deleteMany,", + " " <> createTypeName model <> " (..),", + " " <> rowTypeName model <> " (..),", + " " <> selectTypeName model <> " (..),", + " " <> pickedTypeName model <> " (..),", + " " <> selectDefaultName model <> ",", + " OmitSelect (..),", + " Picked (..),", + " ResolveSelect,", + " " <> updateTypeName model <> " (..),", + " " <> tableTypeName model <> ",", + " " <> queryTypeName model <> " (..),", + " " <> uniqueTypeName model <> " (..),", + " " <> uniqueKeyTypeName model <> " (..),", + " " <> uniqueQueryName model <> " (..),", + " emptyQuery,", + " uniqueQuery,", + " " <> uniqueWhereName model <> ",", + " " <> fieldBinder model (primaryKeyField model), + " )" + ] + +exportLinesFromItems :: [Text] -> [Text] +exportLinesFromItems items = + case items of + [] -> [" ()"] + (first : rest) -> + (" ( " <> first) : map (" " <>) rest ++ [" )"] + +includeClientExportItems :: Schema -> Model -> [Text] +includeClientExportItems schema root = + includeReadFunctionExportItems + ++ [ "create,", + "createMany,", + "update,", + "updateMany,", + "upsert,", + "delete,", + "deleteMany," + ] + ++ nestedWriteExportItems schema root + ++ [ queryTypeName root <> " (..),", + uniqueTypeName root <> " (..),", + uniqueKeyTypeName root <> " (..),", + uniqueQueryName root <> " (..),", + "emptyQuery,", + "uniqueQuery,", + uniqueWhereName root <> ",", + "OmitSelect (..),", + "Picked (..),", + createTypeName root <> " (..),", + rowTypeName root <> " (..),", + selectTypeName root <> " (..),", + pickedTypeName root <> " (..),", + selectDefaultName root <> ",", + updateTypeName root <> " (..),", + tableTypeName root <> ",", + fieldBinder root (primaryKeyField root) + ] + +includeReadFunctionExportItems :: [Text] +includeReadFunctionExportItems = + [ "findMany,", + "findUnique,", + "findUniqueOrFail,", + "findFirst,", + "findFirstOrFail,", + "count," + ] + +includeClientImportLines :: Text -> Schema -> Model -> [Text] +includeClientImportLines moduleName schema root = + nestedPreludeImports schema root + ++ [ includeGeneratedImports schema root, + rootSchemaImport moduleName schema root, + includeModuleImportLine moduleName root + ] + ++ nestedChildSchemaImports moduleName schema root + ++ nestedChildClientImports moduleName schema root + ++ nestedChildEnumImports moduleName schema root + ++ extraValueImports moduleName schema root + +rootSchemaImport :: Text -> Schema -> Model -> Text +rootSchemaImport moduleName schema root + | nestedWriteUsesTransaction schema root = + T.unlines + [ "import " + <> schemaModule moduleName root + <> " (" + <> T.intercalate ", " (rootSchemaNames False) + <> ")", + "import qualified " + <> schemaModule moduleName root + <> " as " + <> schemaModuleAlias root + <> " (" + <> createTypeName root + <> " (..), " + <> updateTypeName root + <> " (..))" + ] + | otherwise = + "import " + <> schemaModule moduleName root + <> " (" + <> T.intercalate ", " (rootSchemaNames True) + <> ")" + where + rootSchemaNames withCreateUpdate = + nub $ + [n | withCreateUpdate, n <- [createTypeName root <> " (..)", updateTypeName root <> " (..)"]] + ++ [ rowTypeName root <> " (..)", + selectTypeName root <> " (..)", + pickedTypeName root <> " (..)", + selectDefaultName root, + selectColumnsFnName root, + parsePickedName root, + tableTypeName root, + uniqueFieldImportList schema root + ] + ++ [ fieldBinder child (lookupField child (relForeignField rel)) + | (rel, child) <- nestedWriteRelations schema root, + modelName child == modelName root + ] + +includeModuleImportLine :: Text -> Model -> Text +includeModuleImportLine moduleName model = + "import " + <> includeModule moduleName model + <> " (" + <> T.intercalate + ", " + [ "Load" <> modelName model <> " (..)", + includeType model <> " (..)", + readType model, + toWithPickedName model + ] + <> ")" + +nestedPreludeImports :: Schema -> Model -> [Text] +nestedPreludeImports schema root + | nestedWriteUsesTransaction schema root = + [ "import Data.Maybe (isJust)", + "import Data.Text (Text)", + "import Data.UUID (UUID)" + ] + | otherwise = ["import Data.UUID (UUID)"] + +simpleGeneratedImports :: Schema -> Model -> Text +simpleGeneratedImports schema model = + T.unlines + [ "import Poppy.Internal.Generated", + " ( Db,", + " ORMError (..),", + " fromUniqueRows,", + " requireFound,", + " uniqueOrFail,", + " OrderBy,", + " QueryBuilder,", + " applyQueryModifiers,", + " matching,", + " selectColumns,", + " OmitSelect (..),", + " Picked (..),", + " " <> T.intercalate ",\n " (whereNames schema model) <> "", + " )", + "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", + " )" + ] + +includeGeneratedImports :: Schema -> Model -> Text +includeGeneratedImports schema root = + let dbNames = + if nestedWriteUsesTransaction schema root + then ["Db", "transactionEither"] + else ["Db"] + nestedNames = + if nestedWriteUsesTransaction schema root + then + ["fieldColumn", "toField"] + ++ ["NullableValue (..)" | needsNestedNullableValue schema root] + else [] + wherePart = whereNames schema root + selectIn = ["prepareIncludeRootQuery"] + in T.unlines + [ "import Poppy.Internal.Generated", + " ( " <> T.intercalate ",\n " (dbNames ++ nestedNames ++ ["ORMError (..)", "fromUniqueRows", "requireFound", "uniqueOrFail", "OrderBy", "applyQueryModifiers", "matching", "selectColumns", "OmitSelect (..)", "Picked (..)"] ++ selectIn ++ wherePart) <> "", + " )", + "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", + " )" + ] + +whereNames :: Schema -> Model -> [Text] +whereNames schema model + | nestedWriteUsesTransaction schema model = ["Where", "and_", "eq"] + | otherwise = + let needsAnd = any ((> 1) . length . emittedFields) (modelUniqueKeys schema model) + in ["Where", "eq"] ++ ["and_" | needsAnd] + +intercalateSections :: [Text] -> Text +intercalateSections sections = + T.intercalate "\n\n" (map T.strip sections) + +emitFindManyFn :: Model -> Text +emitFindManyFn model = + let q = queryTypeName model + uq = uniqueQueryName model + table = tableTypeName model + row = rowTypeName model + whereFn = uniqueWhereName model + in T.unlines $ + [ "class Read" <> modelName model <> " select where", + " findMany :: " <> q <> " select -> Db [ResolveSelect select]", + " findUnique :: " <> uq <> " select -> Db (Either ORMError (Maybe (ResolveSelect select)))", + " findUniqueOrFail :: " <> uq <> " select -> Db (Either ORMError (ResolveSelect select))", + " findFirst :: " <> q <> " select -> Db (Maybe (ResolveSelect select))", + " findFirstOrFail :: " <> q <> " select -> Db (Either ORMError (ResolveSelect select))", + "", + "instance Read" <> modelName model <> " OmitSelect where", + " findMany q =", + " Ops.findMany @" <> table <> " @" <> row <> " (applyQuery q)" + ] + ++ emitFindUniqueByRowsLines + whereFn + (uq <> " {where_}") + ["rows <- Ops.findMany @" <> table <> " @" <> row <> " (matching w)"] + ++ emitFindUniqueOrFailLines + ++ [ " findFirst q =", + " Ops.findFirst @" <> table <> " @" <> row <> " (applyQuery q)" + ] + ++ emitFindFirstOrFailLines + ++ [ "", + "instance Read" <> modelName model <> " " <> selectTypeName model <> " where", + " findMany q@" <> q <> " {select_} =", + " Ops.findManyWith", + " (" <> parsePickedName model <> " select_)", + " (selectColumns (" <> selectColumnsFnName model <> " select_) . applyQuery q)" + ] + ++ emitFindUniqueByRowsLines + whereFn + (uq <> " {where_, select_}") + [ "rows <-", + " Ops.findManyWith", + " (" <> parsePickedName model <> " select_)", + " (selectColumns (" <> selectColumnsFnName model <> " select_) . matching w)" + ] + ++ emitFindUniqueOrFailLines + ++ [ " findFirst q@" <> q <> " {select_} =", + " Ops.findFirstWith", + " (" <> parsePickedName model <> " select_)", + " (selectColumns (" <> selectColumnsFnName model <> " select_) . applyQuery q)" + ] + ++ emitFindFirstOrFailLines + ++ [ "", + "applyQuery :: " <> q <> " select -> QueryBuilder " <> table <> " -> QueryBuilder " <> table, + "applyQuery " <> q <> " {where_, orderBy_, limit_, offset_} =", + " applyQueryModifiers where_ orderBy_ limit_ offset_" + ] + +emitFindUniqueOrFailLines :: [Text] +emitFindUniqueOrFailLines = + [" findUniqueOrFail q = uniqueOrFail <$> findUnique q"] + +emitFindUniqueByRowsLines :: Text -> Text -> [Text] -> [Text] +emitFindUniqueByRowsLines whereFn binding rowLines = + [ " findUnique " <> binding <> " = do", + " let w = " <> whereFn <> " where_" + ] + ++ map (" " <>) rowLines + ++ [" pure (fromUniqueRows rows)"] + +emitFindFirstOrFailLines :: [Text] +emitFindFirstOrFailLines = + [ " findFirstOrFail q = do", + " result <- findFirst q", + " pure $ requireFound result (RecordNotFound \"No record found matching query\")" + ] + +emitCountFn :: Model -> Text +emitCountFn model = + T.unlines + [ "count :: " <> queryTypeName model <> " select -> Db Int", + "count q = Ops.count @" <> tableTypeName model <> " (applyQuery q)" + ] + +emitIncludeCountFn :: Model -> Text +emitIncludeCountFn model = + T.unlines + [ "count :: " <> queryTypeName model <> " include select -> Db Int", + "count " <> queryTypeName model <> " {where_, orderBy_, limit_, offset_} =", + " Ops.count @" <> tableTypeName model <> " (applyQueryModifiers where_ orderBy_ limit_ offset_)" + ] + +emitResolveSelect :: Model -> Text +emitResolveSelect model = + T.unlines + [ "type family ResolveSelect select", + "type instance ResolveSelect OmitSelect = " <> rowTypeName model, + "type instance ResolveSelect " <> selectTypeName model <> " = " <> pickedTypeName model + ] + +emitEmptyQueryFn :: Model -> Text +emitEmptyQueryFn model = + T.unlines + [ "emptyQuery :: " <> queryTypeName model <> " OmitSelect", + "emptyQuery =", + " " <> queryTypeName model <> " {select_ = OmitSelect, where_ = Nothing, orderBy_ = [], limit_ = Nothing, offset_ = Nothing}" + ] + +emitQueryType :: Model -> Text +emitQueryType model = + T.unlines + [ "data " <> queryTypeName model <> " select = " <> queryTypeName model, + " { select_ :: select", + " , where_ :: Maybe (Where " <> tableTypeName model <> ")", + " , orderBy_ :: [OrderBy " <> tableTypeName model <> "]", + " , limit_ :: Maybe Int", + " , offset_ :: Maybe Int", + " }" + ] + +emitDeleteFn :: Model -> Text +emitDeleteFn model = + T.unlines + [ "delete :: " <> uniqueTypeName model <> " -> Db (Either ORMError Int)", + "delete key =", + " Delete.deleteMany @" <> tableTypeName model <> " (" <> uniqueWhereName model <> " key)" + ] + +emitDeleteManyFn :: Model -> Text +emitDeleteManyFn model = + T.unlines + [ "deleteMany :: Where " <> tableTypeName model <> " -> Db (Either ORMError Int)", + "deleteMany = Delete.deleteMany @" <> tableTypeName model + ] + +emitIncludeReadDefinitions :: Schema -> Model -> [Text] +emitIncludeReadDefinitions _schema model = + [ emitIncludeQueryType model, + emitUniqueQueryType True model, + emitIncludeEmptyQueryFn model, + emitUniqueQueryFn True model, + emitIncludeFindManyClass model, + emitIncludeFindManyInstances model, + emitIncludeCountFn model + ] + +emitIncludeQueryType :: Model -> Text +emitIncludeQueryType model = + T.unlines + [ "data " <> queryTypeName model <> " include select = " <> queryTypeName model, + " { include_ :: include", + " , select_ :: select", + " , where_ :: Maybe (Where " <> tableTypeName model <> ")", + " , orderBy_ :: [OrderBy " <> tableTypeName model <> "]", + " , limit_ :: Maybe Int", + " , offset_ :: Maybe Int", + " }" + ] + +emitIncludeEmptyQueryFn :: Model -> Text +emitIncludeEmptyQueryFn model = + T.unlines + [ "emptyQuery :: " <> queryTypeName model <> " () OmitSelect", + "emptyQuery =", + " " <> queryTypeName model <> " {include_ = (), select_ = OmitSelect, where_ = Nothing, orderBy_ = [], limit_ = Nothing, offset_ = Nothing}" + ] + +emitUniqueQueryType :: Bool -> Model -> Text +emitUniqueQueryType withInclude model = + let name = uniqueQueryName model + params = if withInclude then " include select" else " select" + fields = + ["include_ :: include" | withInclude] + ++ [ "select_ :: select", + "where_ :: " <> uniqueTypeName model + ] + in T.unlines $ + ["data " <> name <> params <> " = " <> name] + ++ zipWith fieldLine [0 :: Int ..] fields + ++ [" }"] + where + fieldLine 0 f = " { " <> f + fieldLine _ f = " , " <> f + +emitUniqueQueryFn :: Bool -> Model -> Text +emitUniqueQueryFn withInclude model = + let name = uniqueQueryName model + result = + if withInclude + then name <> " () OmitSelect" + else name <> " OmitSelect" + fields = + ["include_ = ()" | withInclude] + ++ ["select_ = OmitSelect", "where_ = key"] + in T.unlines + [ "uniqueQuery :: " <> uniqueTypeName model <> " -> " <> result, + "uniqueQuery key =", + " " <> name <> " {" <> T.intercalate ", " fields <> "}" + ] + +emitIncludeFindManyClass :: Model -> Text +emitIncludeFindManyClass model = + let query = queryTypeName model + uniqueQuery = uniqueQueryName model + result = readType model <> " include select" + in T.unlines + [ "class Read" <> modelName model <> " include select where", + " findMany :: " <> query <> " include select -> Db [" <> result <> "]", + " findUnique :: " <> uniqueQuery <> " include select -> Db (Either ORMError (Maybe (" <> result <> ")))", + " findUniqueOrFail :: " <> uniqueQuery <> " include select -> Db (Either ORMError (" <> result <> "))", + " findFirst :: " <> query <> " include select -> Db (Maybe (" <> result <> "))", + " findFirstOrFail :: " <> query <> " include select -> Db (Either ORMError (" <> result <> "))" + ] + +emitIncludeFindManyInstances :: Model -> Text +emitIncludeFindManyInstances model = + let table = tableTypeName model + row = rowTypeName model + query = queryTypeName model + uq = uniqueQueryName model + selectTy = selectTypeName model + parseFn = parsePickedName model + colsFn = selectColumnsFnName model + toPicked = toWithPickedName model + modelNm = modelName model + includeTy = includeApplied model + load = loadMethod model + whereFn = uniqueWhereName model + rootFetch modifier = + "Ops.findMany @" <> table <> " @" <> row <> " (prepareIncludeRootQuery @" <> table <> " (" <> modifier <> "))" + in T.unlines $ + [ "instance (" <> loadClass model <> ") => Read" <> modelNm <> " (" <> includeTy <> ") OmitSelect where", + " findMany " <> query <> " {include_, where_, orderBy_, limit_, offset_} = do", + " roots <- " <> rootFetch "applyQueryModifiers where_ orderBy_ limit_ offset_", + " " <> load <> " include_ roots" + ] + ++ emitFindUniqueByRowsLines + whereFn + (uq <> " {where_, include_}") + [ "roots <- " <> rootFetch "matching w", + "rows <- " <> load <> " include_ roots" + ] + ++ emitFindUniqueOrFailLines + ++ emitLoadedFindFirstFor model load False + ++ emitFindFirstOrFailLines + ++ [ "", + "instance Read" <> modelNm <> " () OmitSelect where", + " findMany " <> query <> " {where_, orderBy_, limit_, offset_} =", + " Ops.findMany @" <> table <> " @" <> row <> " (applyQueryModifiers where_ orderBy_ limit_ offset_)" + ] + ++ emitFindUniqueByRowsLines + whereFn + (uq <> " {where_}") + ["rows <- Ops.findMany @" <> table <> " @" <> row <> " (matching w)"] + ++ emitFindUniqueOrFailLines + ++ [ " findFirst " <> query <> " {where_, orderBy_, limit_, offset_} =", + " Ops.findFirst @" <> table <> " @" <> row <> " (applyQueryModifiers where_ orderBy_ limit_ offset_)" + ] + ++ emitFindFirstOrFailLines + ++ [ "", + "instance (" <> loadClass model <> ") => Read" <> modelNm <> " (" <> includeTy <> ") " <> selectTy <> " where", + " findMany " <> query <> " {include_, select_, where_, orderBy_, limit_, offset_} = do", + " roots <- " <> rootFetch "applyQueryModifiers where_ orderBy_ limit_ offset_", + " loaded <- " <> load <> " include_ roots", + " pure $ map (" <> toPicked <> " select_) loaded" + ] + ++ emitFindUniqueByRowsLines + whereFn + (uq <> " {where_, include_, select_}") + [ "roots <- " <> rootFetch "matching w", + "loaded <- " <> load <> " include_ roots", + "let rows = map (" <> toPicked <> " select_) loaded" + ] + ++ emitFindUniqueOrFailLines + ++ emitLoadedFindFirstFor model load True + ++ emitFindFirstOrFailLines + ++ [ "", + "instance Read" <> modelNm <> " () " <> selectTy <> " where", + " findMany " <> query <> " {select_, where_, orderBy_, limit_, offset_} =", + " Ops.findManyWith", + " (" <> parseFn <> " select_)", + " (selectColumns (" <> colsFn <> " select_) . applyQueryModifiers where_ orderBy_ limit_ offset_)" + ] + ++ emitFindUniqueByRowsLines + whereFn + (uq <> " {where_, select_}") + [ "rows <-", + " Ops.findManyWith", + " (" <> parseFn <> " select_)", + " (selectColumns (" <> colsFn <> " select_) . matching w)" + ] + ++ emitFindUniqueOrFailLines + ++ [ " findFirst " <> query <> " {select_, where_, orderBy_, limit_, offset_} =", + " Ops.findFirstWith", + " (" <> parseFn <> " select_)", + " (selectColumns (" <> colsFn <> " select_) . applyQueryModifiers where_ orderBy_ limit_ offset_)" + ] + ++ emitFindFirstOrFailLines + +emitLoadedFindFirstFor :: Model -> Text -> Bool -> [Text] +emitLoadedFindFirstFor model load picked = + [ " findFirst " <> query <> " {" <> T.intercalate ", " fields <> "} = do", + " roots <- Ops.findMany @" <> table <> " @" <> row <> " (prepareIncludeRootQuery @" <> table <> " (applyQueryModifiers where_ orderBy_ (Just 1) offset_))", + " loaded <- " <> load <> " include_ roots", + " pure $ case loaded of", + " [] -> Nothing", + " (row : _) -> Just " <> value + ] + where + query = queryTypeName model + table = tableTypeName model + row = rowTypeName model + fields = (["select_" | picked]) ++ ["include_", "where_", "orderBy_", "offset_"] + value = + if picked + then "(" <> toWithPickedName model <> " select_ row)" + else "row" + +queryTypeName :: Model -> Text +queryTypeName model = modelName model <> "Query" + +schemaModule :: Text -> Model -> Text +schemaModule clientModule model = + clientSchemaPrefix clientModule <> modelName model + +includeModule :: Text -> Model -> Text +includeModule clientModule model = + clientSchemaPrefix clientModule <> "Include." <> modelName model + +paramsOf :: Model -> Text +paramsOf model = T.unwords (map relName (modelRelations model)) + +includeType :: Model -> Text +includeType model = modelName model <> "Include" + +includeApplied :: Model -> Text +includeApplied model = includeType model <> " " <> paramsOf model + +withPickedType :: Model -> Text +withPickedType model = modelName model <> "WithPicked" + +readType :: Model -> Text +readType model = modelName model <> "Read" + +loadClass :: Model -> Text +loadClass model = "Load" <> modelName model <> " " <> paramsOf model + +loadMethod :: Model -> Text +loadMethod model = "load" <> modelName model + +toWithPickedName :: Model -> Text +toWithPickedName model = "to" <> withPickedType model + +data EmittedUnique = EmittedUnique + { emittedCtor :: Text, + emittedKeyCtor :: Text, + emittedFields :: [FieldSpec] + } + +modelUniqueKeys :: Schema -> Model -> [EmittedUnique] +modelUniqueKeys schema model = + emittedFrom (upperFirst (fieldName primary)) [primary] + : map fromConstraint (lookupUniques schema (modelName model)) + where + primary = primaryKeyField model + fromConstraint constraint = + let fields = map (lookupField model) (uniqueFields constraint) + in emittedFrom (T.concat (map (upperFirst . fieldName) fields)) fields + emittedFrom label fields = + EmittedUnique + { emittedCtor = "By" <> label, + emittedKeyCtor = "On" <> label, + emittedFields = fields + } + +uniqueTypeName :: Model -> Text +uniqueTypeName model = modelName model <> "Unique" + +uniqueQueryName :: Model -> Text +uniqueQueryName model = modelName model <> "UniqueQuery" + +uniqueKeyTypeName :: Model -> Text +uniqueKeyTypeName model = modelName model <> "UniqueKey" + +uniqueWhereName :: Model -> Text +uniqueWhereName model = lowerFirst (modelName model) <> "UniqueWhere" + +uniqueConflictName :: Model -> Text +uniqueConflictName model = lowerFirst (modelName model) <> "ConflictCols" + +uniqueFieldImportList :: Schema -> Model -> Text +uniqueFieldImportList schema model = + T.intercalate ", " $ + nub + [ fieldBinder model spec + | key <- modelUniqueKeys schema model, + spec <- emittedFields key + ] + +valueImportsBlock :: Schema -> Text -> Model -> Text +valueImportsBlock schema moduleName model = + T.intercalate "\n" (valueImportLines schema moduleName model) + +valueImportLines :: Schema -> Text -> Model -> [Text] +valueImportLines schema moduleName model = + nub $ + "import Data.Text (Text)" + : concatMap (valueImport schema moduleName) (concatMap emittedFields (modelUniqueKeys schema model)) + +extraValueImports :: Text -> Schema -> Model -> [Text] +extraValueImports moduleName schema model = + filter (`notElem` nestedPreludeImports schema model) $ + nub $ + valueImportLines schema moduleName model + ++ rootFieldImports + ++ concat + [ concatMap (valueImport schema moduleName) nonEnumFields + | (rel, child) <- nestedWriteRelations schema model, + let nonEnumFields = + [ f + | f <- modelFields child ++ [f' | f' <- modelFields child, fieldName f' /= relForeignField rel], + case fieldType f of + TyEnum _ -> False + _ -> True + ] + ] + where + -- Nested-write Clients re-emit root Create/Update, so root scalar types + -- must be in scope here (not only on Schema.). + rootFieldImports + | nestedWriteUsesTransaction schema model = + concatMap (valueImport schema moduleName) (modelFields model) + | otherwise = [] + +-- | True when nested create/update payloads mention 'NullableValue'. +needsNestedNullableValue :: Schema -> Model -> Bool +needsNestedNullableValue schema root = + any fieldNullable (modelFields root) + || any (any fieldNullable . modelFields . snd) (nestedWriteRelations schema root) + +valueImport :: Schema -> Text -> FieldSpec -> [Text] +valueImport schema moduleName spec = + case fieldType spec of + TyText -> [] + TyUuid -> ["import Data.UUID (UUID)"] + TyNumeric -> ["import Data.Scientific (Scientific)"] + TyJsonb -> ["import Data.Aeson (Value)"] + TyTimestamptz -> ["import Data.Time (UTCTime)"] + TyInt -> [] + TyBool -> [] + TyEnum name -> + [ enumImportLine (clientSchemaPrefix moduleName) enumSpec + | enumSpec <- schemaEnums schema, + enumName enumSpec == name + ] + +emitUniqueDecls :: Schema -> Model -> Text +emitUniqueDecls schema model = + let keys = modelUniqueKeys schema model + in T.unlines $ + emitSum (uniqueTypeName model) (map ctorLine keys) + ++ [""] + ++ emitSum (uniqueKeyTypeName model) (map emittedKeyCtor keys) + ++ [""] + ++ emitUniqueWhere model keys + ++ [""] + ++ emitConflictCols model keys + where + ctorLine key = emittedCtor key <> " " <> T.unwords (map emittedArgType (emittedFields key)) + +emitSum :: Text -> [Text] -> [Text] +emitSum name alts = + ["data " <> name] + ++ zipWith arm [0 :: Int ..] alts + ++ [" deriving (Eq, Show)"] + where + arm 0 alt = " = " <> alt + arm _ alt = " | " <> alt + +emitUniqueWhere :: Model -> [EmittedUnique] -> [Text] +emitUniqueWhere model keys = + let fn = uniqueWhereName model + in [ fn <> " :: " <> uniqueTypeName model <> " -> Where " <> tableTypeName model, + fn <> " = \\case" + ] + ++ map arm keys + where + arm key = + let binders = zipWith (\i _ -> "v" <> T.pack (show i)) [1 :: Int ..] (emittedFields key) + preds = + zipWith + (\spec binder -> "eq " <> fieldBinder model spec <> " " <> binder) + (emittedFields key) + binders + in " " + <> emittedCtor key + <> " " + <> T.unwords binders + <> " -> " + <> T.intercalate " `and_` " preds + +emitConflictCols :: Model -> [EmittedUnique] -> [Text] +emitConflictCols model keys = + let fn = uniqueConflictName model + in [ fn <> " :: " <> uniqueKeyTypeName model <> " -> [Text]", + fn <> " = \\case" + ] + ++ map arm keys + where + arm key = + " " + <> emittedKeyCtor key + <> " -> " + <> listLit (map fieldColumn (emittedFields key)) + +listLit :: [Text] -> Text +listLit cols = + "[" <> T.intercalate ", " ["\"" <> col <> "\"" | col <- cols] <> "]" + +emittedArgType :: FieldSpec -> Text +emittedArgType spec = + let base = hsType (fieldType spec) + in if fieldNullable spec then "(Maybe " <> base <> ")" else base diff --git a/src/Poppy/Codegen/Emit/Include.hs b/src/Poppy/Codegen/Emit/Include.hs new file mode 100644 --- /dev/null +++ b/src/Poppy/Codegen/Emit/Include.hs @@ -0,0 +1,656 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Poppy.Codegen.Emit.Include + ( emitIncludeModule, + ) +where + +import Data.List (nubBy) +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import Poppy.Codegen.EmitCommon + ( fieldBinder, + pickedTypeName, + primaryKeyField, + rowTypeName, + selectTypeName, + tableTypeName, + toPickedName, + ) +import Poppy.Codegen.IR +import Poppy.Codegen.Lookup (lookupField, lookupModel) +import Poppy.Codegen.TextUtil (lowerFirst, upperFirst) + +emitIncludeModule :: Text -> Schema -> Model -> Text +emitIncludeModule moduleName schema model + | modelName model /= modelName (representative schema model) = + emitReexport moduleName schema model + | otherwise = + emitComponent moduleName schema (componentModels schema model) + +emitReexport :: Text -> Schema -> Model -> Text +emitReexport moduleName schema model = + T.unlines $ + [ "module " <> moduleName + ] + ++ exportLines (modelExportNames model) + ++ [ "where", + "", + "import " <> repModule <> " (" <> T.intercalate ", " (modelExportNames model) <> ")" + ] + where + rep = representative schema model + repModule = includeModuleName (modulePrefix moduleName model) rep + +emitComponent :: Text -> Schema -> [Model] -> Text +emitComponent moduleName schema models = + T.unlines $ + [ "{-# 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 " <> moduleName + ] + ++ exportLines (concatMap modelExportNames models) + ++ ["where", ""] + ++ emitImports moduleName schema models + ++ [""] + ++ concatMap (\model -> emitModelTypes schema model ++ [""]) models + ++ concatMap (\model -> emitModelLoad schema model ++ [""]) models + +emitImports :: Text -> Schema -> [Model] -> [Text] +emitImports moduleName schema models = + [generatedImport schema models] + ++ concatMap (emitSchemaImport prefix models childNames) (importModels schema models) + ++ map (emitIncludeImport prefix) (externalChildren schema models) + where + prefix = modulePrefix moduleName (head models) + childNames = + [ modelName (childModel schema rel) + | model <- models, + rel <- modelRelations model + ] + +generatedImport :: Schema -> [Model] -> Text +generatedImport schema models = + "import Poppy.Internal.Generated\n ( " + <> T.intercalate ",\n " names + <> "\n )" + where + rels = concatMap modelRelations models + requireRelatedNeeded = + any (any (isRequiredBelongsTo schema) . modelRelations) models + names = + [ "Db", + "IncludeFor", + "Load (..)", + "Skip (..)", + "Skipped", + "ValidEdge", + "skipped", + "OmitSelect (..)" + ] + ++ ["requireRelated" | requireRelatedNeeded] + ++ ["findByIn" | not (null rels)] + ++ ["indexByPk" | any (\rel -> relKind rel == RelBelongsTo) rels] + ++ ["indexHasMany" | any (isPlainHasMany schema) rels] + ++ ["indexHasManyMaybe" | any (isNullableHasMany schema) rels] + ++ ["lookupByPk" | any (\rel -> relKind rel == RelBelongsTo) rels] + ++ ["lookupGroups" | any (\rel -> relKind rel == RelHasMany) rels] + +emitSchemaImport :: Text -> [Model] -> [Text] -> Model -> [Text] +emitSchemaImport prefix component childNames model = + [ "import qualified " <> modName <> " as " <> modelName model + | isChild + ] + ++ [ "import " <> modName <> " (" <> T.intercalate ", " names <> ")" + | not (null names) + ] + where + modName = prefix <> modelName model + inComponent = modelName model `elem` map modelName component + isChild = modelName model `elem` childNames + names = + concat + [ [pickedTypeName model | inComponent], + [rowTypeName model <> " (..)"], + [selectTypeName model | inComponent], + [tableTypeName model | isChild], + [toPickedName model | inComponent] + ] + +emitIncludeImport :: Text -> Model -> Text +emitIncludeImport prefix child = + "import " + <> includeModuleName prefix child + <> " (" + <> T.intercalate ", " names + <> ")" + where + names = + [ modelName child <> "Include (..)", + modelName child <> "Result", + modelName child <> "With (..)", + "Load" <> modelName child <> " (..)" + ] + +emitModelTypes :: Schema -> Model -> [Text] +emitModelTypes schema model = + concat + [ emitIncludeData model, + [""], + emitWithData model False, + [""], + emitWithData model True, + [""], + emitToPicked model, + [""], + concatMap (\rel -> emitEdgeFamily schema model rel ++ [""]) (modelRelations model), + emitResultFamily model, + [""], + emitReadFamily model + ] + +emitIncludeData :: Model -> [Text] +emitIncludeData model = + [ "data " <> includeType model <> " " <> params model <> " = " <> includeType model, + " { " <> T.intercalate ",\n " [relName rel <> " :: " <> relName rel | rel <- modelRelations model], + " }", + " deriving (Show, Eq)" + ] + +emitWithData :: Model -> Bool -> [Text] +emitWithData model picked = + [ "data " <> withName <> " " <> params model <> " = " <> withName, + " { " <> T.intercalate ",\n " fields, + " }", + "", + "deriving instance (" <> ctx "Eq" <> ") => Eq (" <> applied <> ")", + "deriving instance (" <> ctx "Show" <> ") => Show (" <> applied <> ")" + ] + where + withName = if picked then withPickedType model else withType model + rootTy = if picked then pickedTypeName model else rowTypeName model + applied = withName <> " " <> params model + fields = + (rootVar model <> " :: " <> rootTy) + : [ relName rel <> " :: " <> edgeFamily model rel <> " " <> relName rel + | rel <- modelRelations model + ] + ctx cls = + T.intercalate + ", " + ( (cls <> " " <> rootTy) + : [ cls <> " (" <> edgeFamily model rel <> " " <> relName rel <> ")" + | rel <- modelRelations model + ] + ) + +emitToPicked :: Model -> [Text] +emitToPicked model = + [ toWithPickedName model + <> " :: " + <> selectTypeName model + <> " -> " + <> withType model + <> " " + <> params model + <> " -> " + <> withPickedType model + <> " " + <> params model, + toWithPickedName model <> " select_ nested =", + " " <> withPickedType model, + " { " <> T.intercalate ",\n " fields, + " }" + ] + where + fields = + (rootVar model <> " = " <> toPickedName model <> " select_ nested." <> rootVar model) + : [relName rel <> " = nested." <> relName rel | rel <- modelRelations model] + +emitEdgeFamily :: Schema -> Model -> RelationSpec -> [Text] +emitEdgeFamily schema model rel = + [ "type family " <> fam <> " edge where", + " " <> fam <> " Skip = Skipped \"" <> relName rel <> "\" " <> skipTy, + " " <> fam <> " " <> loadPat <> " = " <> loadedTy + ] + where + fam = edgeFamily model rel + child = childModel schema rel + skipTy = wrapSkip (plainLoaded schema rel) + (loadPat, loadedTy) + | hasInclude child = + ("(Load " <> tableTypeName child <> " include)", loadedRhs schema rel "include") + | otherwise = + ("(Load " <> tableTypeName child <> " ())", loadedRhs schema rel "") + +emitResultFamily :: Model -> [Text] +emitResultFamily model = + [ "type family " <> modelName model <> "Result include where", + " " <> modelName model <> "Result () = " <> rowTypeName model, + " " + <> modelName model + <> "Result (" + <> includeType model + <> " " + <> params model + <> ") = " + <> withType model + <> " " + <> params model + ] + +emitReadFamily :: Model -> [Text] +emitReadFamily model = + [ "type family " <> modelName model <> "Read include select where", + " " <> modelName model <> "Read () OmitSelect = " <> rowTypeName model, + " " <> modelName model <> "Read () " <> selectTypeName model <> " = " <> pickedTypeName model, + " " + <> modelName model + <> "Read (" + <> includeType model + <> " " + <> params model + <> ") OmitSelect = " + <> withType model + <> " " + <> params model, + " " + <> modelName model + <> "Read (" + <> includeType model + <> " " + <> params model + <> ") " + <> selectTypeName model + <> " = " + <> withPickedType model + <> " " + <> params model + ] + +emitModelLoad :: Schema -> Model -> [Text] +emitModelLoad schema model = + concatMap (\rel -> emitEdgeLoad schema model rel ++ [""]) (modelRelations model) + ++ emitModelLoadClass model + ++ [""] + ++ emitIncludeFor model + +emitEdgeLoad :: Schema -> Model -> RelationSpec -> [Text] +emitEdgeLoad schema model rel = + emitEdgeClass model rel + ++ [""] + ++ emitSkipInstance model rel + ++ [""] + ++ emitUnitInstance schema model rel + ++ nested + ++ [""] + ++ emitRejectedInstance model rel + where + child = childModel schema rel + nested + | hasInclude child = "" : emitNestedInstance schema model rel child + | otherwise = [] + +emitEdgeClass :: Model -> RelationSpec -> [Text] +emitEdgeClass model rel = + [ "class " <> edgeClass model rel <> " edge where", + " " + <> edgeMethod model rel + <> " :: edge -> [" + <> rowTypeName model + <> "] -> Db [" + <> edgeFamily model rel + <> " edge]" + ] + +emitSkipInstance :: Model -> RelationSpec -> [Text] +emitSkipInstance model rel = + [ "instance " <> edgeClass model rel <> " Skip where", + " " <> edgeMethod model rel <> " Skip roots = pure (map (const skipped) roots)" + ] + +emitUnitInstance :: Schema -> Model -> RelationSpec -> [Text] +emitUnitInstance schema model rel = + [ "instance " <> edgeClass model rel <> " (Load " <> tableTypeName child <> " ()) where", + " " <> edgeMethod model rel <> " edge roots = do" + ] + ++ emitFetch schema model rel + ++ emitGroup schema model rel False + where + child = childModel schema rel + +emitNestedInstance :: Schema -> Model -> RelationSpec -> Model -> [Text] +emitNestedInstance schema model rel child = + [ "instance (" <> loadClass child <> " " <> params child <> ") => " <> edgeClass model rel <> " (Load " <> tableTypeName child <> " (" <> includeType child <> " " <> params child <> ")) where", + " " <> edgeMethod model rel <> " edge roots = do" + ] + ++ emitFetch schema model rel + ++ [" loaded <- " <> loadMethod child <> " edge.include_ rows"] + ++ emitGroup schema model rel True + +emitRejectedInstance :: Model -> RelationSpec -> [Text] +emitRejectedInstance model rel = + [ "instance {-# OVERLAPPABLE #-} (ValidEdge \"" <> relToModel rel <> "\" edge) => " <> edgeClass model rel <> " edge where", + " " <> edgeMethod model rel <> " _ roots = pure (map (const skipped) roots)" + ] + +emitFetch :: Schema -> Model -> RelationSpec -> [Text] +emitFetch schema model rel = + case relKind rel of + RelHasMany -> + [ " rows <- findByIn @" <> tableTypeName child <> " @" <> rowTypeName child <> " " <> fkBinder <> " (map (." <> parentPk <> ") roots) edge.where_ edge.orderBy_ edge.take_" + ] + RelBelongsTo + | isNullableBelongsTo schema rel -> + [ " let keys = [key | root <- roots, Just key <- [root." <> fkName <> "]]", + " rows <- findByIn @" <> tableTypeName child <> " @" <> rowTypeName child <> " " <> pkBinder <> " keys edge.where_ edge.orderBy_ edge.take_" + ] + | otherwise -> + [ " rows <- findByIn @" <> tableTypeName child <> " @" <> rowTypeName child <> " " <> pkBinder <> " (map (." <> fkName <> ") roots) edge.where_ edge.orderBy_ edge.take_" + ] + where + child = childModel schema rel + parentPk = fieldName (primaryKeyField model) + fkName = relForeignField rel + fkField = lookupField child (relForeignField rel) + fkBinder = modelName child <> "." <> fieldBinder child fkField + pkField = lookupField child (relLocalField rel) + pkBinder = modelName child <> "." <> fieldBinder child pkField + +emitGroup :: Schema -> Model -> RelationSpec -> Bool -> [Text] +emitGroup schema model rel nested = + case relKind rel of + RelHasMany -> + [ " let grouped = " <> indexFn <> " " <> keyExpr <> " " <> source, + " pure [lookupGroups root." <> parentPk <> " grouped | root <- roots]" + ] + RelBelongsTo + | isNullableBelongsTo schema rel -> + [ " let indexed = indexByPk " <> keyExpr <> " " <> source, + " pure [root." <> fkName <> " >>= \\key -> lookupByPk key indexed | root <- roots]" + ] + | otherwise -> + [ " let indexed = indexByPk " <> keyExpr <> " " <> source, + " pure [requireRelated \"" <> relName rel <> "\" (lookupByPk root." <> fkName <> " indexed) | root <- roots]" + ] + where + child = childModel schema rel + parentPk = fieldName (primaryKeyField model) + fkName = relForeignField rel + source = if nested then "loaded" else "rows" + indexFn + | isNullableHasMany schema rel = "indexHasManyMaybe" + | otherwise = "indexHasMany" + keyExpr + | nested && relKind rel == RelHasMany = + keyOn (childFkName schema rel) (lowerFirst (modelName child)) + | nested = + keyOn (fieldName (primaryKeyField child)) (lowerFirst (modelName child)) + | relKind rel == RelHasMany = + "(." <> childFkName schema rel <> ")" + | otherwise = + "(." <> fieldName (primaryKeyField child) <> ")" + +emitModelLoadClass :: Model -> [Text] +emitModelLoadClass model = + [ "class " <> loadClass model <> " " <> params model <> " where", + " " + <> loadMethod model + <> " :: " + <> includeType model + <> " " + <> params model + <> " -> [" + <> rowTypeName model + <> "] -> Db [" + <> withType model + <> " " + <> params model + <> "]", + "", + "instance (" <> T.intercalate ", " constraints <> ") => " <> loadClass model <> " " <> params model <> " where", + " " <> loadMethod model <> " include roots = do" + ] + ++ concatMap edgeBind (modelRelations model) + ++ [ " pure", + " [ " <> withType model, + " { " <> T.intercalate ",\n " fields, + " }", + " | (n, root) <- zip [0 :: Int ..] roots", + " ]" + ] + where + constraints = + [edgeClass model rel <> " " <> relName rel | rel <- modelRelations model] + ++ [validEdge model rel | rel <- modelRelations model] + edgeBind rel = + [ " " + <> relName rel + <> "Loaded <- " + <> edgeMethod model rel + <> " include." + <> relName rel + <> " roots" + ] + fields = + (rootVar model <> " = root") + : [relName rel <> " = " <> relName rel <> "Loaded !! n" | rel <- modelRelations model] + +emitIncludeFor :: Model -> [Text] +emitIncludeFor model = + [ "instance (" <> T.intercalate ", " [validEdge model rel | rel <- modelRelations model] <> ") => IncludeFor \"" <> modelName model <> "\" (" <> includeType model <> " " <> params model <> ")" + ] + +validEdge :: Model -> RelationSpec -> Text +validEdge _model rel = + "ValidEdge \"" <> relToModel rel <> "\" " <> relName rel + +childModel :: Schema -> RelationSpec -> Model +childModel schema rel = lookupModel schema (relToModel rel) + +hasInclude :: Model -> Bool +hasInclude model = not (null (modelRelations model)) + +isRequiredBelongsTo :: Schema -> RelationSpec -> Bool +isRequiredBelongsTo schema rel = + relKind rel == RelBelongsTo && not (fieldNullable (lookupField (lookupModel schema (relFromModel rel)) (relForeignField rel))) + +isNullableBelongsTo :: Schema -> RelationSpec -> Bool +isNullableBelongsTo schema rel = + relKind rel == RelBelongsTo && not (isRequiredBelongsTo schema rel) + +isNullableHasMany :: Schema -> RelationSpec -> Bool +isNullableHasMany schema rel = + relKind rel == RelHasMany && fieldNullable (lookupField (childModel schema rel) (relForeignField rel)) + +isPlainHasMany :: Schema -> RelationSpec -> Bool +isPlainHasMany schema rel = + relKind rel == RelHasMany && not (isNullableHasMany schema rel) + +plainLoaded :: Schema -> RelationSpec -> Text +plainLoaded schema rel = + case relKind rel of + RelHasMany -> "[" <> rowTypeName child <> "]" + RelBelongsTo + | isNullableBelongsTo schema rel -> "Maybe " <> rowTypeName child + | otherwise -> rowTypeName child + where + child = childModel schema rel + +wrapSkip :: Text -> Text +wrapSkip ty + | " " `T.isInfixOf` ty = "(" <> ty <> ")" + | otherwise = ty + +loadedRhs :: Schema -> RelationSpec -> Text -> Text +loadedRhs schema rel includeVar = + case relKind rel of + RelHasMany -> "[" <> childTy <> "]" + RelBelongsTo + | isNullableBelongsTo schema rel -> "Maybe (" <> childTy <> ")" + | otherwise -> childTy + where + child = childModel schema rel + childTy + | hasInclude child = modelName child <> "Result" <> includeArg + | otherwise = rowTypeName child + includeArg + | T.null includeVar = "" + | otherwise = " " <> includeVar + +childFkName :: Schema -> RelationSpec -> Text +childFkName schema rel = + fieldName (lookupField (childModel schema rel) (relForeignField rel)) + +keyOn :: Text -> Text -> Text +keyOn keyField accessor = "((." <> keyField <> ") . (." <> accessor <> "))" + +params :: Model -> Text +params model = T.unwords (map relName (modelRelations model)) + +includeType :: Model -> Text +includeType model = modelName model <> "Include" + +withType :: Model -> Text +withType model = modelName model <> "With" + +withPickedType :: Model -> Text +withPickedType model = modelName model <> "WithPicked" + +edgeFamily :: Model -> RelationSpec -> Text +edgeFamily model rel = modelName model <> upperFirst (relName rel) + +edgeClass :: Model -> RelationSpec -> Text +edgeClass model rel = "Load" <> edgeFamily model rel + +edgeMethod :: Model -> RelationSpec -> Text +edgeMethod model rel = "load" <> edgeFamily model rel + +loadClass :: Model -> Text +loadClass model = "Load" <> modelName model + +loadMethod :: Model -> Text +loadMethod model = "load" <> modelName model + +toWithPickedName :: Model -> Text +toWithPickedName model = "to" <> withPickedType model + +rootVar :: Model -> Text +rootVar model = lowerFirst (modelName model) + +modelExportNames :: Model -> [Text] +modelExportNames model = + [ includeType model <> " (..)", + withType model <> " (..)", + withPickedType model <> " (..)" + ] + ++ [edgeFamily model rel | rel <- modelRelations model] + ++ [ modelName model <> "Result", + modelName model <> "Read", + loadClass model <> " (..)", + toWithPickedName model + ] + +exportLines :: [Text] -> [Text] +exportLines [] = [" ()"] +exportLines (first : rest) = + (" ( " <> first) : map (" , " <>) rest ++ [" )"] + +includeModels :: Schema -> [Model] +includeModels schema = filter hasInclude (schemaModels schema) + +componentModels :: Schema -> Model -> [Model] +componentModels schema model = + [m | m <- includeModels schema, modelName m `elem` componentNames] + where + componentNames = + head + [ names + | names <- stronglyConnected (map modelName (includeModels schema)) (neighborNames schema), + modelName model `elem` names + ] + +representative :: Schema -> Model -> Model +representative schema model = head (componentModels schema model) + +neighborNames :: Schema -> Text -> [Text] +neighborNames schema name = + map modelName (deps schema (lookupModel schema name)) + +deps :: Schema -> Model -> [Model] +deps schema model = + nubBy (\a b -> modelName a == modelName b) $ + [ child + | rel <- modelRelations model, + let child = childModel schema rel, + modelName child /= modelName model, + hasInclude child + ] + +importModels :: Schema -> [Model] -> [Model] +importModels schema models = + nubBy (\a b -> modelName a == modelName b) $ + models ++ concatMap (map (childModel schema) . modelRelations) models + +externalChildren :: Schema -> [Model] -> [Model] +externalChildren schema models = + nubBy (\a b -> modelName a == modelName b) $ + [ child + | model <- models, + rel <- modelRelations model, + let child = childModel schema rel, + hasInclude child, + modelName child `notElem` map modelName models + ] + +modulePrefix :: Text -> Model -> Text +modulePrefix moduleName model = + fromMaybe + "Schema." + (T.stripSuffix ("Include." <> modelName model) moduleName) + +includeModuleName :: Text -> Model -> Text +includeModuleName prefix model = prefix <> "Include." <> modelName model + +stronglyConnected :: [Text] -> (Text -> [Text]) -> [[Text]] +stronglyConnected nodes neighbors = + let (_, finish) = dfs neighbors [] [] nodes + in walk (transpose nodes neighbors) [] [] finish + +dfs :: (Text -> [Text]) -> [Text] -> [Text] -> [Text] -> ([Text], [Text]) +dfs _ seen order [] = (seen, order) +dfs neighbors seen order (name : rest) + | name `elem` seen = dfs neighbors seen order rest + | otherwise = + let (seen1, order1) = dfs neighbors (name : seen) order (neighbors name) + in dfs neighbors seen1 (name : order1) rest + +walk :: (Text -> [Text]) -> [Text] -> [[Text]] -> [Text] -> [[Text]] +walk _ _ comps [] = comps +walk incoming seen comps (name : rest) + | name `elem` seen = walk incoming seen comps rest + | otherwise = + let (members, seen1) = collect incoming [] (name : seen) [name] + in walk incoming seen1 (members : comps) rest + +collect :: (Text -> [Text]) -> [Text] -> [Text] -> [Text] -> ([Text], [Text]) +collect _ acc seen [] = (acc, seen) +collect incoming acc seen (name : stack) = + let more = [next | next <- incoming name, next `notElem` seen] + in collect incoming (name : acc) (more ++ seen) (more ++ stack) + +transpose :: [Text] -> (Text -> [Text]) -> Text -> [Text] +transpose nodes neighbors name = + [other | other <- nodes, name `elem` neighbors other] diff --git a/src/Poppy/Codegen/Emit/NestedWrite.hs b/src/Poppy/Codegen/Emit/NestedWrite.hs new file mode 100644 --- /dev/null +++ b/src/Poppy/Codegen/Emit/NestedWrite.hs @@ -0,0 +1,743 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Poppy.Codegen.Emit.NestedWrite + ( nestedWriteRelations, + nestedWriteExportItems, + emitNestedWriteTypes, + emitNestedWriteHelpers, + emitCreateFn, + emitClientCreateManyFn, + emitUpdateFn, + emitUpdateManyFn, + emitClientUpsertFn, + nestedChildSchemaImports, + nestedChildClientImports, + nestedChildEnumImports, + nestedWriteUsesTransaction, + schemaModuleAlias, + childHasForeignKey, + ) +where + +import Data.List (nub, nubBy) +import Data.Maybe (isNothing) +import Data.Text (Text) +import qualified Data.Text as T +import Poppy.Codegen.EmitCommon +import Poppy.Codegen.IR +import Poppy.Codegen.Lookup (lookupField, lookupModel) +import Poppy.Codegen.TextUtil (lowerFirst, upperFirst) + +type NestedRel = (RelationSpec, Model) + +nestedWriteRelations :: Schema -> Model -> [NestedRel] +nestedWriteRelations schema root = + [ (rel, lookupModel schema (relToModel rel)) + | rel <- modelRelations root, + relKind rel == RelHasMany, + childHasForeignKey schema rel + ] + +childHasForeignKey :: Schema -> RelationSpec -> Bool +childHasForeignKey schema rel = + any + ((== relForeignField rel) . fieldName) + (modelFields (lookupModel schema (relToModel rel))) + +nestedWriteUsesTransaction :: Schema -> Model -> Bool +nestedWriteUsesTransaction schema model = + not (null (nestedWriteRelations schema model)) + +schemaModuleAlias :: Model -> Text +schemaModuleAlias model = modelName model <> "Schema" + +nestedWriteExportItems :: Schema -> Model -> [Text] +nestedWriteExportItems schema root = + nub $ + case nestedWriteRelations schema root of + [] -> [] + rels -> + [ createTypeName root <> "Scalars,", + updateTypeName root <> "Scalars," + ] + ++ concat + [ [ nestedCreateTypeName rels rel child <> " (..),", + nestedUpsertTypeName child <> " (..),", + nestedUpdateTypeName rel <> " (..),", + emptyNestedUpdateName rel <> "," + ] + | (rel, child) <- rels + ] + +uniqueByCreateType :: [NestedRel] -> [NestedRel] +uniqueByCreateType rels = + nubBy + ( \(r1, c1) (r2, c2) -> + nestedCreateTypeName rels r1 c1 == nestedCreateTypeName rels r2 c2 + ) + rels + +uniqueByChild :: [NestedRel] -> [NestedRel] +uniqueByChild = + nubBy (\(_, a) (_, b) -> modelName a == modelName b) + +nestedCreateTypeName :: [NestedRel] -> RelationSpec -> Model -> Text +nestedCreateTypeName rels rel child = + if length (nub [relForeignField r | (r, c) <- rels, modelName c == modelName child]) > 1 + then upperFirst (relName rel) <> "NestedCreate" + else modelName child <> "NestedCreate" + +nestedUpsertTypeName :: Model -> Text +nestedUpsertTypeName child = modelName child <> "NestedUpsert" + +nestedUpdateTypeName :: RelationSpec -> Text +nestedUpdateTypeName rel = upperFirst (relName rel) <> "Update" + +emptyNestedUpdateName :: RelationSpec -> Text +emptyNestedUpdateName rel = "empty" <> nestedUpdateTypeName rel + +createCtorName :: Model -> Text +createCtorName child = "Create" <> modelName child + +connectCtorName :: Model -> Text +connectCtorName child = "Connect" <> modelName child + +applyCreateFnName :: RelationSpec -> Text +applyCreateFnName rel = "apply" <> upperFirst (relName rel) <> "Create" + +applyUpdateFnName :: RelationSpec -> Text +applyUpdateFnName rel = "apply" <> nestedUpdateTypeName rel + +insertCreatesFnName :: RelationSpec -> Text +insertCreatesFnName rel = "insert" <> upperFirst (relName rel) + +replaceFnName :: RelationSpec -> Text +replaceFnName rel = "replace" <> upperFirst (relName rel) + +deleteFnName :: RelationSpec -> Text +deleteFnName rel = "delete" <> upperFirst (relName rel) + +updateChildFnName :: RelationSpec -> Text +updateChildFnName rel = "update" <> upperFirst (relName rel) <> "Rows" + +upsertFnName :: RelationSpec -> Text +upsertFnName rel = "upsert" <> upperFirst (relName rel) + +connectFnName :: RelationSpec -> Text +connectFnName rel = "connect" <> upperFirst (relName rel) + +disconnectFnName :: RelationSpec -> Text +disconnectFnName rel = "disconnect" <> upperFirst (relName rel) + +fkField :: Model -> RelationSpec -> FieldSpec +fkField child rel = lookupField child (relForeignField rel) + +nestedPayloadFields :: Model -> RelationSpec -> [FieldSpec] +nestedPayloadFields child rel = + [f | f <- modelFields child, fieldName f /= relForeignField rel] + +pkFieldName :: Model -> Text +pkFieldName model = fieldName (primaryKeyField model) + +childUniqueWhereRef :: Model -> Model -> Text +childUniqueWhereRef root child + | modelName root == modelName child = uniqueWhereName child + | otherwise = modelName child <> "." <> uniqueWhereName child + +childUniqueTypeRef :: Model -> Model -> Text +childUniqueTypeRef root child + | modelName root == modelName child = uniqueTypeName child + | otherwise = modelName child <> "." <> uniqueTypeName child + +childCreateTypeRef :: Model -> Model -> Text +childCreateTypeRef root child + | modelName root == modelName child = schemaModuleAlias root <> "." <> createTypeName child + | otherwise = createTypeName child + +childUpdateTypeRef :: Model -> Model -> Text +childUpdateTypeRef root child + | modelName root == modelName child = schemaModuleAlias root <> "." <> updateTypeName child + | otherwise = updateTypeName child + +toScalarsName :: Model -> Text +toScalarsName model = "to" <> createTypeName model <> "Scalars" + +toUpdateScalarsName :: Model -> Text +toUpdateScalarsName model = "to" <> updateTypeName model <> "Scalars" + +hasCreateNestedName :: Model -> Text +hasCreateNestedName model = "has" <> modelName model <> "NestedCreate" + +hasUpdateNestedName :: Model -> Text +hasUpdateNestedName model = "has" <> modelName model <> "NestedUpdate" + +uniqueConflictName :: Model -> Text +uniqueConflictName model = lowerFirst (modelName model) <> "ConflictCols" + +leaveFkValue :: FieldSpec -> Text +leaveFkValue f + | fieldNullable f = "Omit" + | otherwise = "Nothing" + +fkAssign :: FieldSpec -> Text +fkAssign f + | fieldNullable f = "Value parentId" + | otherwise = "parentId" + +connectFkValue :: FieldSpec -> Text +connectFkValue f + | fieldNullable f = "Value parentId" + | otherwise = "Just parentId" + +ownsParentPred :: Model -> RelationSpec -> Text +ownsParentPred child rel = + let fk = fieldName (fkField child rel) + in if fieldNullable (fkField child rel) + then "row." <> fk <> " == Just parentId" + else "row." <> fk <> " == parentId" + +emitNestedWriteTypes :: Schema -> Model -> Text +emitNestedWriteTypes schema root = + case nestedWriteRelations schema root of + [] -> "" + rels -> + T.unlines $ + map + T.strip + ( map (emitNestedCreateType root rels) (uniqueByCreateType rels) + ++ map (emitNestedUpsertType root rels) (uniqueByChild rels) + ++ map (emitNestedUpdateType root rels) rels + ++ [emitRootCreateType root rels, emitRootUpdateType root rels] + ) + +emitNestedCreateType :: Model -> [NestedRel] -> NestedRel -> Text +emitNestedCreateType root rels (rel, child) = + T.unlines + [ "data " <> nestedCreateTypeName rels rel child, + " = " <> createCtorName child, + " { " <> T.intercalate ", " fieldLines, + " }", + " | " <> connectCtorName child <> " " <> childUniqueTypeRef root child, + " deriving (Show, Eq)" + ] + where + fieldLines = + [ fieldName f <> " :: " <> createHsType f + | f <- nestedPayloadFields child rel + ] + +emitNestedUpsertType :: Model -> [NestedRel] -> NestedRel -> Text +emitNestedUpsertType root rels (rel, child) = + T.unlines + [ "data " <> nestedUpsertTypeName child <> " = " <> nestedUpsertTypeName child, + " { where_ :: " <> childUniqueTypeRef root child, + " , create :: " <> nestedCreateTypeName rels rel child, + " , update :: " <> childUpdateTypeRef root child, + " }", + " deriving (Show, Eq)" + ] + +emitNestedUpdateType :: Model -> [NestedRel] -> NestedRel -> Text +emitNestedUpdateType root rels (rel, child) = + let createTy = nestedCreateTypeName rels rel child + uniqueTy = childUniqueTypeRef root child + nullableFk = fieldNullable (fkField child rel) + in T.unlines $ + [ "data " <> nestedUpdateTypeName rel <> " = " <> nestedUpdateTypeName rel, + " { replaceWith :: Maybe [" <> createTy <> "]", + " , create :: [" <> createTy <> "]", + " , createMany :: [" <> createTy <> "]", + " , connect :: [" <> uniqueTy <> "]", + " , delete :: [" <> uniqueTy <> "]", + " , update :: [(" <> uniqueTy <> ", " <> childUpdateTypeRef root child <> ")]", + " , upsert :: [" <> nestedUpsertTypeName child <> "]" + ] + ++ [" , disconnect :: [" <> uniqueTy <> "]" | nullableFk] + ++ [ " }", + " deriving (Show, Eq)", + "", + emptyNestedUpdateName rel <> " :: " <> nestedUpdateTypeName rel, + emptyNestedUpdateName rel <> " =", + " " <> nestedUpdateTypeName rel, + " { replaceWith = Nothing", + " , create = []", + " , createMany = []", + " , connect = []", + " , delete = []", + " , update = []", + " , upsert = []" + ] + ++ [" , disconnect = []" | nullableFk] + ++ [" }"] + +emitRootCreateType :: Model -> [NestedRel] -> Text +emitRootCreateType root rels = + T.unlines + [ "data " <> createTypeName root <> " = " <> createTypeName root, + " { " <> T.intercalate ",\n " (scalarFields ++ relFields), + " }", + " deriving (Show, Eq)", + "", + "type " <> createTypeName root <> "Scalars = " <> schemaModuleAlias root <> "." <> createTypeName root, + "", + toScalarsName root <> " :: " <> createTypeName root <> " -> " <> createTypeName root <> "Scalars", + toScalarsName root <> " input =", + " " <> schemaModuleAlias root <> "." <> createTypeName root, + " { " <> T.intercalate ",\n " assignFields, + " }" + ] + where + scalarFields = [fieldName f <> " :: " <> createHsType f | f <- modelFields root] + relFields = + [ relName rel <> " :: [" <> nestedCreateTypeName rels rel child <> "]" + | (rel, child) <- rels + ] + assignFields = [fieldName f <> " = input." <> fieldName f | f <- modelFields root] + +emitRootUpdateType :: Model -> [NestedRel] -> Text +emitRootUpdateType root rels = + T.unlines + [ "data " <> updateTypeName root <> " = " <> updateTypeName root, + " { " <> T.intercalate ",\n " (scalarFields ++ relFields), + " }", + " deriving (Show, Eq)", + "", + "type " <> updateTypeName root <> "Scalars = " <> schemaModuleAlias root <> "." <> updateTypeName root, + "", + toUpdateScalarsName root <> " :: " <> updateTypeName root <> " -> " <> updateTypeName root <> "Scalars", + toUpdateScalarsName root <> " input =", + " " <> schemaModuleAlias root <> "." <> updateTypeName root, + " { " <> T.intercalate ",\n " assignFields, + " }" + ] + where + scalarFields = [fieldName f <> " :: " <> updateHsType f | f <- updateFields root] + relFields = [relName rel <> " :: Maybe " <> nestedUpdateTypeName rel | (rel, _) <- rels] + assignFields = [fieldName f <> " = input." <> fieldName f | f <- updateFields root] + +emitCreateFn :: Schema -> Model -> Text +emitCreateFn schema model = + case nestedWriteRelations schema model of + [] -> + T.unlines + [ "create :: " <> createTypeName model <> " -> Db (Either ORMError " <> rowTypeName model <> ")", + "create = Insert.insert @" <> tableTypeName model <> " @" <> rowTypeName model + ] + rels -> + T.unlines + [ "create :: " <> createTypeName model <> " -> Db (Either ORMError " <> rowTypeName model <> ")", + "create input =", + " if " <> hasCreateNestedName model <> " input", + " then transactionEither (createWithNested input)", + " else Insert.insert @" <> table <> " @" <> row <> " (" <> toScalarsName model <> " input)", + "", + hasCreateNestedName model <> " :: " <> createTypeName model <> " -> Bool", + hasCreateNestedName model <> " input =", + " " <> T.intercalate " || " ["not (null input." <> relName rel <> ")" | (rel, _) <- rels], + "", + "createWithNested :: " <> createTypeName model <> " -> Db (Either ORMError " <> rowTypeName model <> ")", + "createWithNested input = do", + " rootResult <- Insert.insert @" <> table <> " @" <> row <> " (" <> toScalarsName model <> " input)", + " case rootResult of", + " Left err -> pure (Left err)", + " Right row -> do", + " nestedResult <-", + " sequenceNested", + " [ " <> T.intercalate "\n , " applyCalls, + " ]", + " case nestedResult of", + " Left err -> pure (Left err)", + " Right () -> pure (Right row)" + ] + where + table = tableTypeName model + row = rowTypeName model + applyCalls = + [ applyCreateFnName rel <> " row." <> pkFieldName model <> " input." <> relName rel + | (rel, _) <- nestedWriteRelations schema model + ] + +emitClientCreateManyFn :: Schema -> Model -> Text +emitClientCreateManyFn schema model = + T.unlines + [ "createMany :: [" <> scalars <> "] -> Db (Either ORMError Int)", + "createMany = Insert.insertMany @" <> tableTypeName model + ] + where + scalars = + if nestedWriteUsesTransaction schema model + then createTypeName model <> "Scalars" + else createTypeName model + +emitUpdateFn :: Schema -> Model -> Text +emitUpdateFn schema model = + case nestedWriteRelations schema model of + [] -> + T.unlines + [ "update :: " <> uniqueTypeName model <> " -> " <> updateTypeName model <> " -> Db (Either ORMError " <> rowTypeName model <> ")", + "update key input =", + " Update.updateWhere @" <> tableTypeName model <> " @" <> rowTypeName model <> " (" <> uniqueWhereName model <> " key) input" + ] + rels -> + T.unlines + [ "update :: " <> uniqueTypeName model <> " -> " <> updateTypeName model <> " -> Db (Either ORMError " <> rowTypeName model <> ")", + "update key input =", + " if " <> hasUpdateNestedName model <> " input", + " then transactionEither (updateWithNested key input)", + " else Update.updateWhere @" <> table <> " @" <> row <> " (" <> uniqueWhereName model <> " key) (" <> toUpdateScalarsName model <> " input)", + "", + hasUpdateNestedName model <> " :: " <> updateTypeName model <> " -> Bool", + hasUpdateNestedName model <> " input =", + " " <> T.intercalate " || " ["isJust input." <> relName rel | (rel, _) <- rels], + "", + "updateWithNested :: " <> uniqueTypeName model <> " -> " <> updateTypeName model <> " -> Db (Either ORMError " <> rowTypeName model <> ")", + "updateWithNested key input = do", + " updateResult <- Update.updateWhere @" <> table <> " @" <> row <> " (" <> uniqueWhereName model <> " key) (" <> toUpdateScalarsName model <> " input)", + " case updateResult of", + " Left err -> pure (Left err)", + " Right row -> do", + " nestedResult <-", + " sequenceNested", + " [ " <> T.intercalate "\n , " applyCalls, + " ]", + " case nestedResult of", + " Left err -> pure (Left err)", + " Right () -> pure (Right row)" + ] + where + table = tableTypeName model + row = rowTypeName model + applyCalls = + [ "maybe (pure (Right ())) (" <> applyUpdateFnName rel <> " row." <> pkFieldName model <> ") input." <> relName rel + | (rel, _) <- nestedWriteRelations schema model + ] + +emitUpdateManyFn :: Schema -> Model -> Text +emitUpdateManyFn schema model = + T.unlines + [ "updateMany :: Where " <> tableTypeName model <> " -> " <> scalars <> " -> Db (Either ORMError Int)", + "updateMany = Update.updateMany @" <> tableTypeName model + ] + where + scalars = + if nestedWriteUsesTransaction schema model + then updateTypeName model <> "Scalars" + else updateTypeName model + +emitClientUpsertFn :: Schema -> Model -> Text +emitClientUpsertFn schema model = + T.unlines + [ "upsert :: " <> uniqueKeyTypeName model <> " -> " <> createTy <> " -> " <> updateTy <> " -> Db (Either ORMError " <> rowTypeName model <> ")", + "upsert key createInput updateInput =", + " Insert.upsert @" <> tableTypeName model <> " @" <> rowTypeName model <> " (" <> uniqueConflictName model <> " key) createInput updateInput" + ] + where + nested = nestedWriteUsesTransaction schema model + createTy = if nested then createTypeName model <> "Scalars" else createTypeName model + updateTy = if nested then updateTypeName model <> "Scalars" else updateTypeName model + +emitNestedWriteHelpers :: Schema -> Model -> Text +emitNestedWriteHelpers schema root = + case nestedWriteRelations schema root of + [] -> "" + rels -> + T.unlines $ + map T.strip $ + emitSequenceNested : concatMap (emitRelHelpers root rels) rels + +emitSequenceNested :: Text +emitSequenceNested = + T.unlines + [ "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" + ] + +emitRelHelpers :: Model -> [NestedRel] -> NestedRel -> [Text] +emitRelHelpers root rels nested@(rel, child) = + [ emitApplyCreate root rels nested, + emitApplyUpdate root nested, + emitReplaceFn root rels nested, + emitInsertCreateFn root rels nested, + emitDeleteFn root nested, + emitUpdateChildFn root nested, + emitUpsertFn root nested, + emitConnectFn root nested + ] + ++ [emitDisconnectFn root nested | fieldNullable (fkField child rel)] + +emitApplyCreate :: Model -> [NestedRel] -> NestedRel -> Text +emitApplyCreate root rels (rel, child) = + T.unlines + [ applyCreateFnName rel <> " :: " <> pkHsType root <> " -> [" <> nestedCreateTypeName rels rel child <> "] -> Db (Either ORMError ())", + applyCreateFnName rel <> " = " <> insertCreatesFnName rel + ] + +emitApplyUpdate :: Model -> NestedRel -> Text +emitApplyUpdate root (rel, child) = + T.unlines $ + [ applyUpdateFnName rel <> " :: " <> pkHsType root <> " -> " <> nestedUpdateTypeName rel <> " -> Db (Either ORMError ())", + applyUpdateFnName rel <> " parentId ops = do", + " replaced <- case ops.replaceWith of", + " Nothing -> pure (Right ())", + " Just items -> " <> replaceFnName rel <> " parentId items", + " case replaced of", + " Left err -> pure (Left err)", + " Right () ->", + " sequenceNested", + " [ " <> deleteFnName rel <> " parentId ops.delete", + " , " <> updateChildFnName rel <> " parentId ops.update", + " , " <> upsertFnName rel <> " parentId ops.upsert", + " , " <> insertCreatesFnName rel <> " parentId ops.create", + " , " <> insertCreatesFnName rel <> " parentId ops.createMany", + " , " <> connectFnName rel <> " parentId ops.connect" + ] + ++ [" , " <> disconnectFnName rel <> " parentId ops.disconnect" | fieldNullable (fkField child rel)] + ++ [" ]"] + +emitReplaceFn :: Model -> [NestedRel] -> NestedRel -> Text +emitReplaceFn root rels (rel, child) = + T.unlines + [ replaceFnName rel <> " :: " <> pkHsType root <> " -> [" <> nestedCreateTypeName rels rel child <> "] -> Db (Either ORMError ())", + replaceFnName rel <> " parentId items = do", + " result <-", + " Delete.deleteWhere $", + " Delete.whereDelete (fieldColumn " <> fkBinder <> " <> \" = ?\") [toField parentId] (Delete.emptyDelete @" <> tableTypeName child <> ")", + " case result of", + " Left err -> pure (Left err)", + " Right _ -> " <> insertCreatesFnName rel <> " parentId items" + ] + where + fkBinder = fieldBinder child (fkField child rel) + +emitInsertCreateFn :: Model -> [NestedRel] -> NestedRel -> Text +emitInsertCreateFn root rels (rel, child) = + T.unlines + [ insertCreatesFnName rel <> " :: " <> pkHsType root <> " -> [" <> nestedCreateTypeName rels rel child <> "] -> Db (Either ORMError ())", + insertCreatesFnName rel <> " parentId = go", + " where", + " go [] = pure (Right ())", + " go (nested : rest) = do", + " result <- case nested of", + " " <> connectCtorName child <> " key -> " <> connectFnName rel <> " parentId [key]", + " " <> createCtorName child <> " {" <> T.intercalate ", " binders <> "} -> do", + " inserted <- Insert.insert @" <> tableTypeName child <> " @" <> rowTypeName child <> " " <> childCreateTypeRef root child, + " { " <> T.intercalate ",\n " assigns, + " }", + " pure $ case inserted of", + " Left err -> Left err", + " Right _ -> Right ()", + " case result of", + " Left err -> pure (Left err)", + " Right () -> go rest" + ] + where + payload = nestedPayloadFields child rel + binders = map fieldName payload + fk = fkField child rel + assigns = + [fieldName f <> " = " <> fieldName f | f <- payload] + ++ [fieldName fk <> " = " <> fkAssign fk] + +emitDeleteFn :: Model -> NestedRel -> Text +emitDeleteFn root (rel, child) = + T.unlines + [ deleteFnName rel <> " :: " <> pkHsType root <> " -> [" <> childUniqueTypeRef root child <> "] -> Db (Either ORMError ())", + deleteFnName rel <> " _ [] = pure (Right ())", + deleteFnName rel <> " parentId keys = sequenceNested (map deleteOne keys)", + " where", + " deleteOne key = do", + " result <- Delete.deleteMany @" <> tableTypeName child, + " (" <> childUniqueWhereRef root child <> " key `and_` eq " <> fkBinder <> " parentId)", + " pure $ case result of", + " Left err -> Left err", + " Right _ -> Right ()" + ] + where + fkBinder = fieldBinder child (fkField child rel) + +emitUpdateChildFn :: Model -> NestedRel -> Text +emitUpdateChildFn root (rel, child) = + T.unlines + [ updateChildFnName rel <> " :: " <> pkHsType root <> " -> [(" <> childUniqueTypeRef root child <> ", " <> childUpdateTypeRef root child <> ")] -> Db (Either ORMError ())", + updateChildFnName rel <> " parentId = go", + " where", + " go [] = pure (Right ())", + " go ((key, nested) : rest) = do", + " let patched = " <> leaveFkUpdateExpr root child rel "nested", + " result <-", + " Update.updateWhere @" <> tableTypeName child <> " @" <> rowTypeName child, + " (" <> childUniqueWhereRef root child <> " key `and_` eq " <> fkBinder <> " parentId)", + " patched", + " case result of", + " Left err -> pure (Left err)", + " Right _ -> go rest" + ] + where + fkBinder = fieldBinder child (fkField child rel) + +leaveFkUpdateExpr :: Model -> Model -> RelationSpec -> Text -> Text +leaveFkUpdateExpr root child rel source = + childUpdateTypeRef root child + <> " { " + <> T.intercalate ", " fields + <> " }" + where + fk = fkField child rel + fields = + [ if fieldName f == fieldName fk + then fieldName f <> " = " <> leaveFkValue fk + else fieldName f <> " = " <> source <> "." <> fieldName f + | f <- updateFields child + ] + +emitUpsertFn :: Model -> NestedRel -> Text +emitUpsertFn root (rel, child) = + T.unlines + [ upsertFnName rel <> " :: " <> pkHsType root <> " -> [" <> nestedUpsertTypeName child <> "] -> Db (Either ORMError ())", + upsertFnName rel <> " parentId = go", + " where", + " go [] = pure (Right ())", + " go (item : rest) = do", + " existing <- Ops.findMany @" <> tableTypeName child <> " @" <> rowTypeName child <> " (matching (" <> childUniqueWhereRef root child <> " item.where_))", + " result <- case fromUniqueRows existing of", + " Left err -> pure (Left err)", + " Right Nothing -> " <> insertCreatesFnName rel <> " parentId [item.create]", + " Right (Just row) ->", + " if " <> ownsParentPred child rel, + " then do", + " let patched = " <> leaveFkUpdateExpr root child rel "item.update", + " updated <-", + " Update.updateWhere @" <> tableTypeName child <> " @" <> rowTypeName child, + " (" <> childUniqueWhereRef root child <> " item.where_ `and_` eq " <> fkBinder <> " 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" + ] + where + fkBinder = fieldBinder child (fkField child rel) + +emitConnectFn :: Model -> NestedRel -> Text +emitConnectFn root (rel, child) = + T.unlines + [ connectFnName rel <> " :: " <> pkHsType root <> " -> [" <> childUniqueTypeRef root child <> "] -> Db (Either ORMError ())", + connectFnName rel <> " _ [] = pure (Right ())", + connectFnName rel <> " parentId keys = sequenceNested (map connectOne keys)", + " where", + " connectOne key = do", + " result <-", + " Update.updateWhere @" <> tableTypeName child <> " @" <> rowTypeName child, + " (" <> childUniqueWhereRef root child <> " key)", + " (" <> childUpdateTypeRef root child, + " { " <> T.intercalate ",\n " setFields, + " })", + " pure $ case result of", + " Left err -> Left err", + " Right _ -> Right ()" + ] + where + fk = fkField child rel + setFields = + [ if fieldName f == fieldName fk + then fieldName f <> " = " <> connectFkValue fk + else fieldName f <> " = " <> leaveFkValue f + | f <- updateFields child + ] + +emitDisconnectFn :: Model -> NestedRel -> Text +emitDisconnectFn root (rel, child) = + T.unlines + [ disconnectFnName rel <> " :: " <> pkHsType root <> " -> [" <> childUniqueTypeRef root child <> "] -> Db (Either ORMError ())", + disconnectFnName rel <> " _ [] = pure (Right ())", + disconnectFnName rel <> " parentId keys = sequenceNested (map disconnectOne keys)", + " where", + " disconnectOne key = do", + " result <-", + " Update.updateWhere @" <> tableTypeName child <> " @" <> rowTypeName child, + " (" <> childUniqueWhereRef root child <> " key `and_` eq " <> fkBinder <> " parentId)", + " (" <> childUpdateTypeRef root child, + " { " <> T.intercalate ",\n " setFields, + " })", + " pure $ case result of", + " Left err -> Left err", + " Right _ -> Right ()" + ] + where + fk = fkField child rel + fkBinder = fieldBinder child fk + setFields = + [ if fieldName f == fieldName fk + then fieldName f <> " = Null" + else fieldName f <> " = " <> leaveFkValue f + | f <- updateFields child + ] + +nestedChildSchemaImports :: Text -> Schema -> Model -> [Text] +nestedChildSchemaImports moduleName schema root = + [ childSchemaImport moduleName nested + | nested@(_, child) <- uniqueByChild (nestedWriteRelations schema root), + modelName child /= modelName root + ] + +childSchemaImport :: Text -> NestedRel -> Text +childSchemaImport moduleName (rel, child) = + "import " + <> schemaModuleFor moduleName child + <> " (" + <> T.intercalate ", " names + <> ")" + where + names = + [ rowTypeName child <> " (..)", + tableTypeName child, + fieldBinder child (primaryKeyField child), + fieldBinder child (fkField child rel) + ] + ++ [ createTypeName child <> " (..)", + updateTypeName child <> " (..)" + ] + +nestedChildClientImports :: Text -> Schema -> Model -> [Text] +nestedChildClientImports moduleName schema root = + [ childClientImport moduleName child + | (_, child) <- uniqueByChild (nestedWriteRelations schema root), + modelName child /= modelName root + ] + +childClientImport :: Text -> Model -> Text +childClientImport moduleName child = + "import qualified " + <> childClientModule moduleName child + <> " as " + <> modelName child + <> " (" + <> uniqueTypeName child + <> " (..), " + <> uniqueWhereName child + <> ")" + +childClientModule :: Text -> Model -> Text +childClientModule clientModule child = + case T.breakOnEnd "." clientModule of + (prefix, _) -> prefix <> modelName child + +nestedChildEnumImports :: Text -> Schema -> Model -> [Text] +nestedChildEnumImports moduleName schema root = + nub + [ "import " <> clientSchemaPrefix moduleName <> enumName e <> " (" <> enumName e <> " (..))" + | (_, child) <- uniqueByChild (nestedWriteRelations schema root), + f <- modelFields child, + TyEnum wanted <- [fieldType f], + e <- schemaEnums schema, + enumName e == wanted, + isNothing (enumImport e) + ] diff --git a/src/Poppy/Codegen/Emit/Schema.hs b/src/Poppy/Codegen/Emit/Schema.hs new file mode 100644 --- /dev/null +++ b/src/Poppy/Codegen/Emit/Schema.hs @@ -0,0 +1,500 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Poppy.Codegen.Emit.Schema + ( emitModelModule, + emitEnumModule, + enumImportLine, + schemaEnumPrefix, + ) +where + +import Data.Maybe (fromMaybe, mapMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import Poppy.Codegen.EmitCommon + ( CreateKind (..), + createHsType, + createKind, + createTypeName, + fieldBinder, + hsType, + parsePickedName, + pickedTypeName, + pkHsType, + primaryKeyField, + rowTypeName, + selectColumnsFnName, + selectDefaultName, + selectTypeName, + tableTypeName, + toPickedName, + updateFields, + updateHsType, + updateTypeName, + ) +import Poppy.Codegen.IR +import Poppy.Codegen.Lookup (lookupField, lookupUniques) +import Poppy.Codegen.TextUtil (lowerFirst) + +emitModelModule :: Text -> Schema -> Model -> Text +emitModelModule moduleName schema model = + T.unlines $ + concat + [ pragmas, + [ "module " <> moduleName, + emitExports model, + "where", + "", + imports moduleName schema model, + "", + "data " <> tableName_ <> " = " <> tableName_, + "", + "type instance PrimaryKeyType " <> tableName_ <> " = " <> pkHsType model, + "", + "type instance ModelTable \"" <> modelName model <> "\" = " <> tableName_, + "", + "instance Entity " <> tableName_ <> " where", + " tableName = \"" <> modelTable model <> "\"", + " primaryKey = " <> fieldBinder model pkField, + " tableColumns = [" <> T.intercalate ", " (map colLit (modelFields model)) <> "]" + ] + ++ uniqueKeysLines schema model + ++ [ "", + emitInsertable model, + "", + emitUpdatable model, + "", + emitRow model, + "", + emitCreate model, + "", + emitUpdate model, + "", + emitFromRow model, + "", + emitSelectTypes model, + "" + ], + concatMap (emitFieldDecl model) (modelFields model) + ] + where + tableName_ = tableTypeName model + pkField = primaryKeyField model + +emitExports :: Model -> Text +emitExports model = + " ( " + <> T.intercalate ",\n " items + <> "\n )" + where + items = + [ tableTypeName model <> " (..)", + rowTypeName model <> " (..)", + selectTypeName model <> " (..)", + pickedTypeName model <> " (..)", + selectDefaultName model, + selectColumnsFnName model, + parsePickedName model, + toPickedName model, + createTypeName model <> " (..)", + updateTypeName model <> " (..)" + ] + ++ map (fieldBinder model) (modelFields model) + +pragmas :: [Text] +pragmas = + [ "{-# LANGUAGE AllowAmbiguousTypes #-}", + "{-# LANGUAGE DataKinds #-}", + "{-# LANGUAGE DuplicateRecordFields #-}", + "{-# LANGUAGE NoFieldSelectors #-}", + "{-# LANGUAGE OverloadedRecordDot #-}", + "{-# LANGUAGE TypeApplications #-}", + "" + ] + +imports :: Text -> Schema -> Model -> Text +imports moduleName schema model = + T.intercalate "\n" $ + filter + (not . T.null) + [ "import Data.Text (Text)", + if needsTime model then "import Data.Time (UTCTime)" else "", + if needsUuid model then "import Data.UUID (UUID)" else "", + if needsScientific model then "import Data.Scientific (Scientific)" else "", + if needsJsonb model then "import Data.Aeson (Value)" else "", + generatedImport model + ] + ++ enumImports moduleName schema model + +enumImports :: Text -> Schema -> Model -> [Text] +enumImports moduleName schema model = + [ enumImportLine (schemaEnumPrefix moduleName) e + | e <- schemaEnums schema, + enumName e `elem` usedEnumNames + ] + where + usedEnumNames = + [ name + | f <- modelFields model, + TyEnum name <- [fieldType f] + ] + +schemaEnumPrefix :: Text -> Text +schemaEnumPrefix moduleName = + case T.breakOnEnd "." moduleName of + (prefix, _) | not (T.null prefix) -> prefix + _ -> "" + +enumImportLine :: Text -> EnumSpec -> Text +enumImportLine prefix e = + "import " <> enumImportModule prefix e <> " (" <> enumName e <> ")" + +enumImportModule :: Text -> EnumSpec -> Text +enumImportModule prefix e = + case enumImport e of + Just imp -> imp + Nothing -> prefix <> enumName e + +enumToStringName :: EnumSpec -> Text +enumToStringName e = lowerFirst (enumName e) <> "ToString" + +emitEnumModule :: Text -> EnumSpec -> Text +emitEnumModule moduleName e = + T.unlines + [ "{-# LANGUAGE OverloadedStrings #-}", + "", + "module " <> moduleName, + " ( " <> enumName e <> " (..),", + " " <> enumToStringName e, + " )", + "where", + "", + "import Data.Maybe (isNothing)", + "import Data.Text (Text)", + "import Poppy.Internal.Generated", + " ( FromField (..),", + " ResultError (ConversionFailed, UnexpectedNull),", + " returnError,", + " ToField (..),", + " toField,", + " )", + "", + emitEnumData e, + "", + emitEnumFromField e, + "", + emitEnumToField e, + "", + emitEnumToString e + ] + +emitEnumData :: EnumSpec -> Text +emitEnumData e = + T.unlines + [ "data " <> enumName e <> " = " <> T.intercalate " | " (map variantName (enumVariants e)), + " deriving (Show, Eq)" + ] + +emitEnumFromField :: EnumSpec -> Text +emitEnumFromField e = + T.unlines $ + [ "instance FromField " <> enumName e <> " where", + " fromField f bs", + " | isNothing bs = returnError UnexpectedNull f \"\"" + ] + ++ [ " | bs == Just \"" <> variantDbStr v <> "\" = pure " <> variantName v + | v <- enumVariants e + ] + ++ [" | otherwise = returnError ConversionFailed f \"\""] + +emitEnumToField :: EnumSpec -> Text +emitEnumToField e = + T.unlines + [ "instance ToField " <> enumName e <> " where", + " toField = toField . " <> enumToStringName e + ] + +emitEnumToString :: EnumSpec -> Text +emitEnumToString e = + T.unlines $ + (enumToStringName e <> " :: " <> enumName e <> " -> Text") + : [ enumToStringName e <> " " <> variantName v <> " = \"" <> variantDbStr v <> "\"" + | v <- enumVariants e + ] + +variantDbStr :: EnumVariant -> Text +variantDbStr v = fromMaybe (lowerFirst (variantName v)) (variantDbValue v) + +generatedImport :: Model -> Text +generatedImport model = + let needsNullable = any fieldNullable (modelFields model) + needsMaybe = any ((== CreateMaybe) . createKind) (modelFields model) + needsUpdateNullable = any fieldNullable (updateFields model) + needsUpdateMaybe = (not . all fieldNullable) (updateFields model) + parts = + [ "FromRow (..)", + "RowParser", + "field", + "Entity (..)", + "Field (..)", + "PrimaryKeyType", + "ModelTable", + "Picked (..)", + "picked", + "Insertable (..)", + "emptyInsert" + ] + ++ ["NullableValue (..)" | needsNullable] + ++ ["set" | hasRequiredCreateField model] + ++ ["setMaybe" | needsMaybe] + ++ ["setNullable" | needsNullable] + ++ ["Updatable (..)", "emptyUpdate"] + ++ ["setFieldMaybe" | needsUpdateMaybe] + ++ ["setFieldNullable" | needsUpdateNullable] + in "import Poppy.Internal.Generated\n ( " + <> T.intercalate ",\n " parts + <> "\n )" + +needsTime :: Model -> Bool +needsTime = any ((== TyTimestamptz) . fieldType) . modelFields + +needsUuid :: Model -> Bool +needsUuid = any (isUuidType . fieldType) . modelFields + where + isUuidType TyUuid = True + isUuidType _ = False + +needsScientific :: Model -> Bool +needsScientific = any ((== TyNumeric) . fieldType) . modelFields + +needsJsonb :: Model -> Bool +needsJsonb = any ((== TyJsonb) . fieldType) . modelFields + +hasRequiredCreateField :: Model -> Bool +hasRequiredCreateField = + any (\f -> createKind f == CreateRequired) . modelFields + +rowHsType :: FieldSpec -> Text +rowHsType f + | fieldNullable f = "Maybe " <> hsType (fieldType f) + | otherwise = hsType (fieldType f) + +emitRow :: Model -> Text +emitRow model = + T.unlines + [ "data " <> rowTypeName model <> " = " <> rowTypeName model, + " { " <> T.intercalate ",\n " (map rowField (modelFields model)), + " }", + " deriving (Show, Eq)" + ] + where + rowField f = fieldName f <> " :: " <> rowHsType f + +emitCreate :: Model -> Text +emitCreate model = + T.unlines + [ "data " <> createTypeName model <> " = " <> createTypeName model, + " { " <> T.intercalate ",\n " (map createField (modelFields model)), + " }", + " deriving (Show, Eq)" + ] + where + createField f = fieldName f <> " :: " <> createHsType f + +emitUpdate :: Model -> Text +emitUpdate model = + T.unlines + [ "data " <> updateTypeName model <> " = " <> updateTypeName model, + " { " <> T.intercalate ",\n " (map updateField (updateFields model)), + " }", + " deriving (Show, Eq)" + ] + where + updateField f = fieldName f <> " :: " <> updateHsType f + +emitFromRow :: Model -> Text +emitFromRow model = + let n = length (modelFields model) + fields = T.intercalate " <*> " (replicate n "field") + in T.unlines + [ "instance FromRow " <> rowTypeName model <> " where", + " fromRow = " <> rowTypeName model <> " <$> " <> fields + ] + +colLit :: FieldSpec -> Text +colLit f = "\"" <> fieldColumn f <> "\"" + +uniqueKeysLines :: Schema -> Model -> [Text] +uniqueKeysLines schema model = + case lookupUniques schema (modelName model) of + [] -> [] + uniques -> + [ " uniqueKeys = [" + <> T.intercalate ", " (map emitKey (pkCols : map uniqueCols uniques)) + <> "]" + ] + where + pkCols = [fieldColumn (primaryKeyField model)] + uniqueCols constraint = map (fieldColumn . lookupField model) (uniqueFields constraint) + emitKey cols = "[" <> T.intercalate ", " (map (\c -> "\"" <> c <> "\"") cols) <> "]" + +pickedFieldHsType :: FieldSpec -> Text +pickedFieldHsType f + | fieldIsPrimaryKey f = rowHsType f + | fieldNullable f = "Picked (" <> rowHsType f <> ")" + | otherwise = "Picked " <> rowHsType f + +emitSelectTypes :: Model -> Text +emitSelectTypes model = + T.intercalate "\n" (map T.strip sections) <> "\n" + where + sections = + [ emitSelectRecord model, + emitPickedRecord model, + emitSelectDefault model, + emitSelectColumnsFn model, + emitParsePicked model, + emitToPicked model + ] + +emitSelectRecord :: Model -> Text +emitSelectRecord model = + T.unlines + [ "data " <> selectTypeName model <> " = " <> selectTypeName model, + " { " <> T.intercalate ",\n " (map selectField (modelFields model)), + " }", + " deriving (Show, Eq)" + ] + where + selectField f = fieldName f <> " :: Bool" + +emitPickedRecord :: Model -> Text +emitPickedRecord model = + T.unlines + [ "data " <> pickedTypeName model <> " = " <> pickedTypeName model, + " { " <> T.intercalate ",\n " (map pickedField (modelFields model)), + " }", + " deriving (Show, Eq)" + ] + where + pickedField f = fieldName f <> " :: " <> pickedFieldHsType f + +emitSelectDefault :: Model -> Text +emitSelectDefault model = + T.unlines + [ selectDefaultName model <> " :: " <> selectTypeName model, + selectDefaultName model <> " =", + " " <> selectTypeName model, + " { " <> T.intercalate ",\n " (map falseField (modelFields model)), + " }" + ] + where + falseField f = fieldName f <> " = False" + +emitSelectColumnsFn :: Model -> Text +emitSelectColumnsFn model = + T.unlines + [ selectColumnsFnName model <> " :: " <> selectTypeName model <> " -> [Text]", + selectColumnsFnName model <> " select_ =", + " fieldColumn " <> fieldBinder model pkSpec, + " : concat", + " [ " <> T.intercalate "\n , " (map colGuard others), + " ]" + ] + where + pkSpec = primaryKeyField model + others = filter (not . fieldIsPrimaryKey) (modelFields model) + colGuard f = + "[fieldColumn " <> fieldBinder model f <> " | select_." <> fieldName f <> "]" + +emitParsePicked :: Model -> Text +emitParsePicked model = + T.unlines $ + [ parsePickedName model <> " :: " <> selectTypeName model <> " -> RowParser " <> pickedTypeName model, + parsePickedName model <> " select_ = do", + " " <> pkName <> "Val <- field" + ] + ++ map parseLine others + ++ [ " pure " + <> pickedTypeName model + <> " { " + <> T.intercalate ", " assignFields + <> " }" + ] + where + pkSpec = primaryKeyField model + pkName = fieldName pkSpec + others = filter (not . fieldIsPrimaryKey) (modelFields model) + parseLine f = + " " <> fieldName f <> "Val <- if select_." <> fieldName f <> " then Picked <$> field else pure Skipped" + assignFields = + (pkName <> " = " <> pkName <> "Val") + : [fieldName f <> " = " <> fieldName f <> "Val" | f <- others] + +emitToPicked :: Model -> Text +emitToPicked model = + T.unlines + [ toPickedName model <> " :: " <> selectTypeName model <> " -> " <> rowTypeName model <> " -> " <> pickedTypeName model, + toPickedName model <> " select_ row =", + " " <> pickedTypeName model, + " { " <> T.intercalate ",\n " assignFields, + " }" + ] + where + assignFields = map assign (modelFields model) + assign f + | fieldIsPrimaryKey f = fieldName f <> " = row." <> fieldName f + | otherwise = fieldName f <> " = picked select_." <> fieldName f <> " row." <> fieldName f + +emitFieldDecl :: Model -> FieldSpec -> [Text] +emitFieldDecl model f = + [ binder <> " :: Field " <> tableTypeName model <> " " <> hsType (fieldType f), + binder <> " = Field \"" <> fieldName f <> "\" \"" <> fieldColumn f <> "\"", + "" + ] + where + binder = fieldBinder model f + +emitInsertable :: Model -> Text +emitInsertable model = + T.unlines + [ "instance Insertable " <> tableTypeName model <> " where", + " type CreateInput " <> tableTypeName model <> " = " <> createTypeName model, + " toInsertBuilder input =", + " " <> body + ] + where + fields = modelFields model + body = foldr wrap ("emptyInsert @" <> tableTypeName model) fields + wrap f inner = case createKind f of + CreateNullable -> + "setNullable " <> fieldBinder model f <> " input." <> fieldName f <> " $\n " <> inner + CreateMaybe -> + "setMaybe " <> fieldBinder model f <> " input." <> fieldName f <> " $\n " <> inner + CreateRequired -> + "set " <> fieldBinder model f <> " input." <> fieldName f <> " $\n " <> inner + +emitUpdatable :: Model -> Text +emitUpdatable model = + T.unlines + [ "instance Updatable " <> tableTypeName model <> " where", + " type UpdateInput " <> tableTypeName model <> " = " <> updateTypeName model, + updatedAtLine, + " toUpdateBuilder input =", + " " <> body + ] + where + fields = updateFields model + body = foldr wrap ("emptyUpdate @" <> tableTypeName model) fields + wrap f inner + | fieldNullable f = + "setFieldNullable " <> fieldBinder model f <> " input." <> fieldName f <> " $\n " <> inner + | otherwise = + "setFieldMaybe " <> fieldBinder model f <> " input." <> fieldName f <> " $\n " <> inner + updatedAtLine = + case mapMaybe updatedAtBinder (modelFields model) of + (b : _) -> " updatedAtField = Just " <> b + [] -> " updatedAtField = Nothing" + updatedAtBinder f + | fieldUpdatedAt f = Just (fieldBinder model f) + | otherwise = Nothing diff --git a/src/Poppy/Codegen/EmitCommon.hs b/src/Poppy/Codegen/EmitCommon.hs new file mode 100644 --- /dev/null +++ b/src/Poppy/Codegen/EmitCommon.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Poppy.Codegen.EmitCommon + ( fieldBinder, + hsType, + primaryKeyField, + includeFieldName, + createTypeName, + updateTypeName, + tableTypeName, + rowTypeName, + selectTypeName, + pickedTypeName, + selectDefaultName, + selectColumnsFnName, + parsePickedName, + toPickedName, + uniqueTypeName, + uniqueWhereName, + uniqueKeyTypeName, + CreateKind (..), + createKind, + createHsType, + updateHsType, + updateFields, + pkHsType, + clientSchemaPrefix, + schemaModuleFor, + ) +where + +import Data.Maybe (isJust) +import Data.Text (Text) +import qualified Data.Text as T +import Poppy.Codegen.IR +import Poppy.Codegen.TextUtil (lowerFirst, upperFirst) + +fieldBinder :: Model -> FieldSpec -> Text +fieldBinder model f = + lowerFirst (modelName model) <> upperFirst (fieldName f) + +hsType :: FieldType -> Text +hsType TyText = "Text" +hsType TyUuid = "UUID" +hsType TyInt = "Int" +hsType TyNumeric = "Scientific" +hsType TyJsonb = "Value" +hsType TyTimestamptz = "UTCTime" +hsType TyBool = "Bool" +hsType (TyEnum name) = name + +primaryKeyField :: Model -> FieldSpec +primaryKeyField model = + case filter fieldIsPrimaryKey (modelFields model) of + [f] -> f + _ -> + error $ + "Poppy.Codegen.EmitCommon: model " + <> T.unpack (modelName model) + <> " must have exactly one primary key" + +includeFieldName :: Model -> RelationSpec -> Text +includeFieldName _parent = relName + +createTypeName :: Model -> Text +createTypeName model = modelName model <> "Create" + +updateTypeName :: Model -> Text +updateTypeName model = modelName model <> "Update" + +tableTypeName :: Model -> Text +tableTypeName model = modelName model <> "Table" + +rowTypeName :: Model -> Text +rowTypeName model = modelName model <> "Row" + +selectTypeName :: Model -> Text +selectTypeName model = modelName model <> "Select" + +pickedTypeName :: Model -> Text +pickedTypeName model = modelName model <> "Picked" + +selectDefaultName :: Model -> Text +selectDefaultName model = lowerFirst (modelName model) <> "Select" + +selectColumnsFnName :: Model -> Text +selectColumnsFnName model = lowerFirst (modelName model) <> "SelectColumns" + +parsePickedName :: Model -> Text +parsePickedName model = "parse" <> modelName model <> "Picked" + +toPickedName :: Model -> Text +toPickedName model = "to" <> modelName model <> "Picked" + +uniqueTypeName :: Model -> Text +uniqueTypeName model = modelName model <> "Unique" + +uniqueWhereName :: Model -> Text +uniqueWhereName model = lowerFirst (modelName model) <> "UniqueWhere" + +uniqueKeyTypeName :: Model -> Text +uniqueKeyTypeName model = modelName model <> "UniqueKey" + +data CreateKind = CreateMaybe | CreateNullable | CreateRequired + deriving (Eq) + +createKind :: FieldSpec -> CreateKind +createKind f + | fieldIsPrimaryKey f && isJust (fieldDefault f) = CreateMaybe + | fieldIsPrimaryKey f = CreateRequired + | isJust (fieldDefault f) = CreateMaybe + | fieldNullable f = CreateNullable + | otherwise = CreateRequired + +createHsType :: FieldSpec -> Text +createHsType f = case createKind f of + CreateMaybe -> "Maybe " <> hsType (fieldType f) + CreateNullable -> "NullableValue " <> hsType (fieldType f) + CreateRequired -> hsType (fieldType f) + +updateFields :: Model -> [FieldSpec] +updateFields = filter (not . fieldIsPrimaryKey) . modelFields + +updateHsType :: FieldSpec -> Text +updateHsType f + | fieldNullable f = "NullableValue " <> hsType (fieldType f) + | otherwise = "Maybe " <> hsType (fieldType f) + +pkHsType :: Model -> Text +pkHsType model = hsType (fieldType (primaryKeyField model)) + +-- | Schema types live next to the Client unless the Client is nested under Schema. +-- +-- @Foo.Client.Bar@ → @Foo.Schema.@ (sibling Client/Schema packages) +-- @Schema.Client.Bar@ → @Schema.@ (Client nested under Schema) +clientSchemaPrefix :: Text -> Text +clientSchemaPrefix clientModule = + case T.breakOnEnd ".Client." clientModule of + (before, after) + | not (T.null after) && ".Client." `T.isSuffixOf` before -> + let parent = T.take (T.length before - T.length ".Client.") before + in if parent == "Schema" + then "Schema." + else parent <> ".Schema." + _ -> "Schema." + +schemaModuleFor :: Text -> Model -> Text +schemaModuleFor clientModule model = + clientSchemaPrefix clientModule <> modelName model diff --git a/src/Poppy/Codegen/IR.hs b/src/Poppy/Codegen/IR.hs new file mode 100644 --- /dev/null +++ b/src/Poppy/Codegen/IR.hs @@ -0,0 +1,227 @@ +-- | Schema value types. Application code builds Schemas with "Poppy.Codegen.Schema", not this module. +module Poppy.Codegen.IR + ( Schema (..), + Model (..), + EnumSpec (..), + EnumVariant (..), + FieldSpec (..), + FieldType (..), + FieldDefault (..), + RelationSpec (..), + RelationKind (..), + JoinKind (..), + UniqueConstraint (..), + field, + uuid, + text, + int, + numeric, + jsonb, + timestamptz, + bool, + enumField, + pk, + nullable, + updatedAt, + withDefault, + column, + enum_, + enumImportFrom, + variant, + variantMap, + hasMany, + belongsTo, + unique_, + ) +where + +import Data.Text (Text) + +-- | Enums, models, and uniques. +data Schema = Schema + { schemaEnums :: [EnumSpec], + schemaModels :: [Model], + schemaUniques :: [UniqueConstraint] + } + deriving (Show, Eq) + +-- | Unique constraint: model name plus field names (not columns). +data UniqueConstraint = UniqueConstraint + { uniqueModel :: Text, + uniqueFields :: [Text] + } + deriving (Show, Eq) + +-- | Postgres enum in the Schema. +data EnumSpec = EnumSpec + { enumName :: Text, + enumVariants :: [EnumVariant], + enumImport :: Maybe Text + } + deriving (Show, Eq) + +-- | Haskell constructor and optional distinct Postgres label. +data EnumVariant = EnumVariant + { variantName :: Text, + variantDbValue :: Maybe Text + } + deriving (Show, Eq) + +-- | One table: fields and relations. +data Model = Model + { modelName :: Text, + modelTable :: Text, + modelFields :: [FieldSpec], + modelRelations :: [RelationSpec] + } + deriving (Show, Eq) + +-- | Column types Codegen emits and drift-checks. +data FieldType + = TyText + | TyUuid + | TyInt + | TyNumeric + | TyJsonb + | TyTimestamptz + | TyBool + | TyEnum Text + deriving (Show, Eq) + +-- | Application-side default; the SQL column must have a matching @DEFAULT@. +data FieldDefault + = DefaultUuidV4 + | DefaultNow + deriving (Show, Eq) + +-- | One column on a model. +data FieldSpec = FieldSpec + { fieldName :: Text, + fieldColumn :: Text, + fieldType :: FieldType, + fieldNullable :: Bool, + fieldIsPrimaryKey :: Bool, + fieldDefault :: Maybe FieldDefault, + fieldUpdatedAt :: Bool + } + deriving (Show, Eq) + +-- | @RelHasMany@ or @RelBelongsTo@. +data RelationKind = RelHasMany | RelBelongsTo + deriving (Show, Eq) + +-- | @LEFT@ / @INNER@ / @RIGHT@ for ad-hoc join emission. +data JoinKind = JoinLeft | JoinInner | JoinRight + deriving (Show, Eq) + +-- | @hasMany@ or @belongsTo@ edge on a model. +data RelationSpec = RelationSpec + { relName :: Text, + relKind :: RelationKind, + relFromModel :: Text, + relToModel :: Text, + relLocalField :: Text, + relForeignField :: Text, + relJoin :: JoinKind + } + deriving (Show, Eq) + +field :: Text -> FieldType -> FieldSpec +field name ty = + FieldSpec + { fieldName = name, + fieldColumn = name, + fieldType = ty, + fieldNullable = False, + fieldIsPrimaryKey = False, + fieldDefault = Nothing, + fieldUpdatedAt = False + } + +uuid :: Text -> FieldSpec +uuid name = field name TyUuid + +text :: Text -> FieldSpec +text name = field name TyText + +int :: Text -> FieldSpec +int name = field name TyInt + +numeric :: Text -> FieldSpec +numeric name = field name TyNumeric + +jsonb :: Text -> FieldSpec +jsonb name = field name TyJsonb + +timestamptz :: Text -> FieldSpec +timestamptz name = field name TyTimestamptz + +bool :: Text -> FieldSpec +bool name = field name TyBool + +enumField :: Text -> Text -> FieldSpec +enumField name enumName = field name (TyEnum enumName) + +-- | Exactly one primary key per model. +pk :: FieldSpec -> FieldSpec +pk f = f {fieldIsPrimaryKey = True} + +-- | @Maybe@ on the row; create/update use 'Poppy.NullableValue'. +nullable :: FieldSpec -> FieldSpec +nullable f = f {fieldNullable = True} + +-- | Client writes set this column to now. +updatedAt :: FieldSpec -> FieldSpec +updatedAt f = f {fieldUpdatedAt = True} + +withDefault :: FieldDefault -> FieldSpec -> FieldSpec +withDefault d f = f {fieldDefault = Just d} + +column :: Text -> FieldSpec -> FieldSpec +column col f = f {fieldColumn = col} + +-- | Postgres enum. Labels default to the Haskell constructor names. +enum_ :: Text -> [EnumVariant] -> EnumSpec +enum_ name variants = + EnumSpec {enumName = name, enumVariants = variants, enumImport = Nothing} + +-- | Skip generating the sum type; import this module instead. +enumImportFrom :: Text -> EnumSpec -> EnumSpec +enumImportFrom moduleName e = e {enumImport = Just moduleName} + +-- | Enum constructor; Postgres label is the same spelling. +variant :: Text -> EnumVariant +variant name = EnumVariant {variantName = name, variantDbValue = Nothing} + +-- | Enum constructor with a different Postgres label. +variantMap :: Text -> Text -> EnumVariant +variantMap name dbValue = + EnumVariant {variantName = name, variantDbValue = Just dbValue} + +hasMany :: Text -> Text -> Text -> Text -> Text -> RelationSpec +hasMany name fromModel toModel localFld foreignFld = + RelationSpec + { relName = name, + relKind = RelHasMany, + relFromModel = fromModel, + relToModel = toModel, + relLocalField = localFld, + relForeignField = foreignFld, + relJoin = JoinLeft + } + +belongsTo :: Text -> Text -> Text -> Text -> Text -> RelationSpec +belongsTo name fromModel toModel foreignFld referencedFld = + RelationSpec + { relName = name, + relKind = RelBelongsTo, + relFromModel = fromModel, + relToModel = toModel, + relLocalField = referencedFld, + relForeignField = foreignFld, + relJoin = JoinLeft + } + +-- | Unique constraint (field names, not columns). @findUnique@ and @upsert@ conflict use these. +unique_ :: Text -> [Text] -> UniqueConstraint +unique_ model fields = UniqueConstraint {uniqueModel = model, uniqueFields = fields} diff --git a/src/Poppy/Codegen/Introspect.hs b/src/Poppy/Codegen/Introspect.hs new file mode 100644 --- /dev/null +++ b/src/Poppy/Codegen/Introspect.hs @@ -0,0 +1,180 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Poppy.Codegen.Introspect + ( introspectCatalog, + canonicalizeColumnType, + ) +where + +import Data.Int (Int32) +import Data.List (foldl', sortOn) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Text (Text) +import Database.PostgreSQL.Simple (Connection, query_) +import Database.PostgreSQL.Simple.Types (Query) +import Poppy.Codegen.Drift (DbCatalog (..), DbColumn (..), DbForeignKey (..), DbTable (..), emptyCatalog) + +type ColumnRow = (Text, Text, Text, Text, Text, Maybe Text) + +type PkRow = (Text, Text, Int32) + +type UniqueRow = (Text, Text, Text, Int32) + +type EnumRow = (Text, Text) + +type FkRow = (Text, Text, Text, Text) + +introspectCatalog :: Connection -> IO DbCatalog +introspectCatalog conn = do + columns <- query_ conn columnSql + pks <- query_ conn pkSql + uniques <- query_ conn uniqueSql + enums <- query_ conn enumSql + fks <- query_ conn fkSql + pure $ + emptyCatalog + { dbTables = buildTables columns pks uniques, + dbEnums = buildEnums enums, + dbForeignKeys = buildForeignKeys fks + } + +canonicalizeColumnType :: Text -> Text -> Text +canonicalizeColumnType dataType udtName = + case dataType of + "text" -> "text" + "uuid" -> "uuid" + "integer" -> "int" + "numeric" -> "numeric" + "jsonb" -> "jsonb" + "timestamp with time zone" -> "timestamptz" + "boolean" -> "boolean" + "USER-DEFINED" -> "enum:" <> udtName + _ -> udtName + +buildTables :: [ColumnRow] -> [PkRow] -> [UniqueRow] -> Map Text DbTable +buildTables columns pks uniques = + Map.mapWithKey + ( \name table -> + table + { dbPrimaryKey = Map.findWithDefault [] name pkMap, + dbUniques = Map.findWithDefault [] name uniqueMap + } + ) + columnTables + where + columnTables = foldl' addColumn Map.empty columns + pkMap = Map.fromListWith (flip (++)) [(table, [col]) | (table, col, _) <- sortOn pkOrd pks] + uniqueMap = uniqueSets uniques + +addColumn :: Map Text DbTable -> ColumnRow -> Map Text DbTable +addColumn acc (table, col, nullable, dataType, udtName, columnDefault) = + Map.alter upsert table acc + where + column = + DbColumn + { dbColName = col, + dbColType = canonicalizeColumnType dataType udtName, + dbColNullable = nullable == "YES", + dbColDefault = columnDefault + } + upsert Nothing = + Just + DbTable + { dbTableName = table, + dbColumns = Map.singleton col column, + dbPrimaryKey = [], + dbUniques = [] + } + upsert (Just existing) = + Just existing {dbColumns = Map.insert col column (dbColumns existing)} + +pkOrd :: PkRow -> (Text, Int32) +pkOrd (table, _, pos) = (table, pos) + +uniqueSets :: [UniqueRow] -> Map Text [Set Text] +uniqueSets rows = + Map.fromListWith + (++) + [ (table, [Set.fromList (map (\(_, _, col, _) -> col) grouped)]) + | grouped@((table, _, _, _) : _) <- groupByConstraint (sortOn uniqueOrd rows) + ] + +uniqueOrd :: UniqueRow -> (Text, Text, Int32) +uniqueOrd (table, constraint, _, pos) = (table, constraint, pos) + +groupByConstraint :: [UniqueRow] -> [[UniqueRow]] +groupByConstraint [] = [] +groupByConstraint (row : rest) = + let (same, others) = span (sameConstraint row) rest + in (row : same) : groupByConstraint others + +sameConstraint :: UniqueRow -> UniqueRow -> Bool +sameConstraint (tableA, nameA, _, _) (tableB, nameB, _, _) = + tableA == tableB && nameA == nameB + +buildEnums :: [EnumRow] -> Map Text [Text] +buildEnums rows = + Map.fromListWith (flip (++)) [(name, [label]) | (name, label) <- rows] + +buildForeignKeys :: [FkRow] -> [DbForeignKey] +buildForeignKeys = + map + ( \(fromTable, fromCol, toTable, toCol) -> + DbForeignKey + { dbFkFromTable = fromTable, + dbFkFromColumn = fromCol, + dbFkToTable = toTable, + dbFkToColumn = toCol + } + ) + +columnSql :: Query +columnSql = + "SELECT table_name, column_name, is_nullable, data_type, udt_name, column_default\ + \ FROM information_schema.columns\ + \ WHERE table_schema = 'public'" + +pkSql :: Query +pkSql = + "SELECT kcu.table_name, kcu.column_name, kcu.ordinal_position\ + \ FROM information_schema.table_constraints tc\ + \ JOIN information_schema.key_column_usage kcu\ + \ ON tc.constraint_name = kcu.constraint_name\ + \ AND tc.table_schema = kcu.table_schema\ + \ WHERE tc.table_schema = 'public'\ + \ AND tc.constraint_type = 'PRIMARY KEY'\ + \ ORDER BY kcu.table_name, kcu.ordinal_position" + +uniqueSql :: Query +uniqueSql = + "SELECT kcu.table_name, tc.constraint_name, kcu.column_name, kcu.ordinal_position\ + \ FROM information_schema.table_constraints tc\ + \ JOIN information_schema.key_column_usage kcu\ + \ ON tc.constraint_name = kcu.constraint_name\ + \ AND tc.table_schema = kcu.table_schema\ + \ WHERE tc.table_schema = 'public'\ + \ AND tc.constraint_type = 'UNIQUE'\ + \ ORDER BY kcu.table_name, tc.constraint_name, kcu.ordinal_position" + +enumSql :: Query +enumSql = + "SELECT t.typname, e.enumlabel\ + \ FROM pg_type t\ + \ JOIN pg_enum e ON t.oid = e.enumtypid\ + \ ORDER BY t.typname, e.enumsortorder" + +fkSql :: Query +fkSql = + "SELECT kcu.table_name, kcu.column_name, ccu.table_name, ccu.column_name\ + \ FROM information_schema.table_constraints tc\ + \ JOIN information_schema.key_column_usage kcu\ + \ ON tc.constraint_name = kcu.constraint_name\ + \ AND tc.table_schema = kcu.table_schema\ + \ JOIN information_schema.constraint_column_usage ccu\ + \ ON ccu.constraint_name = tc.constraint_name\ + \ AND ccu.constraint_schema = tc.table_schema\ + \ WHERE tc.table_schema = 'public'\ + \ AND tc.constraint_type = 'FOREIGN KEY'" diff --git a/src/Poppy/Codegen/Lookup.hs b/src/Poppy/Codegen/Lookup.hs new file mode 100644 --- /dev/null +++ b/src/Poppy/Codegen/Lookup.hs @@ -0,0 +1,47 @@ +module Poppy.Codegen.Lookup + ( lookupModel, + lookupField, + lookupRelation, + lookupUniques, + ) +where + +import Data.List (find) +import Data.Text (Text) +import qualified Data.Text as T +import Poppy.Codegen.IR + +lookupModel :: Schema -> Text -> Model +lookupModel schema name = + case find ((== name) . modelName) (schemaModels schema) of + Just foundModel -> foundModel + Nothing -> + error $ + "Poppy.Codegen.Lookup: unknown model " + <> T.unpack name + +lookupField :: Model -> Text -> FieldSpec +lookupField model name = + case find ((== name) . fieldName) (modelFields model) of + Just spec -> spec + Nothing -> + error $ + "Poppy.Codegen.Lookup: unknown field " + <> T.unpack name + <> " on " + <> T.unpack (modelName model) + +lookupRelation :: Model -> Text -> RelationSpec +lookupRelation model name = + case find ((== name) . relName) (modelRelations model) of + Just relation -> relation + Nothing -> + error $ + "Poppy.Codegen.Lookup: unknown relation " + <> T.unpack name + <> " on " + <> T.unpack (modelName model) + +lookupUniques :: Schema -> Text -> [UniqueConstraint] +lookupUniques schema name = + filter ((== name) . uniqueModel) (schemaUniques schema) diff --git a/src/Poppy/Codegen/Run.hs b/src/Poppy/Codegen/Run.hs new file mode 100644 --- /dev/null +++ b/src/Poppy/Codegen/Run.hs @@ -0,0 +1,54 @@ +module Poppy.Codegen.Run + ( GenOutput (..), + allOutputs, + checkOutputs, + writeOutputs, + schemasForTargets, + ) +where + +import Data.Text (Text, strip) +import qualified Data.Text.IO as TIO +import Poppy.Codegen.IR (Schema) +import Poppy.Codegen.Target + ( CodegenTarget, + GenOutput (..), + targetOutputs, + targetSchemas, + ) +import System.Directory (createDirectoryIfMissing, doesFileExist) +import System.FilePath (takeDirectory, ()) + +schemasForTargets :: [CodegenTarget] -> [Schema] +schemasForTargets = targetSchemas + +allOutputs :: [CodegenTarget] -> [GenOutput] +allOutputs = concatMap targetOutputs + +writeOutputs :: FilePath -> [CodegenTarget] -> IO () +writeOutputs root targets = mapM_ (writeOutput root) (allOutputs targets) + +checkOutputs :: FilePath -> [CodegenTarget] -> IO [FilePath] +checkOutputs root targets = filterMismatches root (allOutputs targets) + +writeOutput :: FilePath -> GenOutput -> IO () +writeOutput root GenOutput {outputPath = path, outputText = text} = do + let fullPath = root path + createDirectoryIfMissing True (takeDirectory fullPath) + TIO.writeFile fullPath text + +filterMismatches :: FilePath -> [GenOutput] -> IO [FilePath] +filterMismatches root = foldr go (pure []) + where + go GenOutput {outputPath = path, outputText = expected} acc = do + mismatches <- acc + let fullPath = root path + exists <- doesFileExist fullPath + if not exists + then pure (path : mismatches) + else do + actual <- TIO.readFile fullPath + pure (if stripText actual == stripText expected then mismatches else path : mismatches) + +stripText :: Text -> Text +stripText = strip diff --git a/src/Poppy/Codegen/Schema.hs b/src/Poppy/Codegen/Schema.hs new file mode 100644 --- /dev/null +++ b/src/Poppy/Codegen/Schema.hs @@ -0,0 +1,158 @@ +-- | Table and column names default from Haskell names (@Task@ → @task@, @createdAt@ → @created_at@). +-- +-- Application Schemas live in a codegen executable and are passed to +-- 'Poppy.Codegen.CLI.generate'. Field types, relations, and uniques are +-- documented in the repository @docs/schema.md@. +module Poppy.Codegen.Schema + ( Schema, + schema, + Model, + model, + table, + FieldSpec, + FieldType (..), + FieldDefault (..), + uuid, + text, + int, + numeric, + jsonb, + bool, + timestamptz, + enumField, + pk, + nullable, + updatedAt, + withDefault, + column, + (&), + RelationSpec, + RelationKind (..), + JoinKind (..), + hasMany, + belongsTo, + EnumSpec (..), + EnumVariant (..), + enum_, + enumImportFrom, + variant, + variantMap, + UniqueConstraint (..), + unique_, + ) +where + +import Data.Function ((&)) +import Data.Text (Text) +import Poppy.Codegen.IR + ( EnumSpec (..), + EnumVariant (..), + FieldDefault (..), + FieldSpec (..), + FieldType (..), + JoinKind (..), + Model (..), + RelationKind (..), + RelationSpec (..), + Schema (..), + UniqueConstraint (..), + enumImportFrom, + enum_, + nullable, + pk, + unique_, + updatedAt, + variant, + variantMap, + ) +import qualified Poppy.Codegen.IR as IR +import Poppy.Codegen.TextUtil (camelToSnake) + +-- | Application-side default (@Maybe@ on create) and a drift requirement: +-- the SQL migration must set the matching column @DEFAULT@. +-- +-- * 'DefaultUuidV4' → @uuid_generate_v4()@ or @gen_random_uuid()@ +-- * 'DefaultNow' → @now()@ or @CURRENT_TIMESTAMP@ +withDefault :: FieldDefault -> FieldSpec -> FieldSpec +withDefault = IR.withDefault + +-- | Enums, models, and uniques. +schema :: [EnumSpec] -> [Model] -> [UniqueConstraint] -> Schema +schema enums models uniques = + Schema + { schemaEnums = enums, + schemaModels = models, + schemaUniques = uniques + } + +-- | @model \"Task\" fields relations@. Table name defaults to snake_case of the model name. +model :: Text -> [FieldSpec] -> [RelationSpec] -> Model +model name fields rels = + Model + { modelName = name, + modelTable = camelToSnake name, + modelFields = fields, + modelRelations = map bind rels + } + where + bind rel = rel {relFromModel = name} + +-- | Override the Postgres table name (@model \"Task\" … & table \"tasks\"@). +table :: Text -> Model -> Model +table name m = m {modelTable = name} + +-- | @uuid@ column. Haskell type @UUID@. +uuid :: Text -> FieldSpec +uuid = typedField IR.TyUuid + +-- | @text@ column. Haskell type @Text@. +text :: Text -> FieldSpec +text = typedField IR.TyText + +-- | @integer@ column. Haskell type @Int@. +int :: Text -> FieldSpec +int = typedField IR.TyInt + +-- | @numeric@ column. Haskell type @Scientific@. +numeric :: Text -> FieldSpec +numeric = typedField IR.TyNumeric + +-- | @jsonb@ column. Haskell type 'Data.Aeson.Value'. +jsonb :: Text -> FieldSpec +jsonb = typedField IR.TyJsonb + +-- | @boolean@ column. +bool :: Text -> FieldSpec +bool = typedField IR.TyBool + +-- | @timestamptz@ column. Haskell type @UTCTime@. +timestamptz :: Text -> FieldSpec +timestamptz = typedField IR.TyTimestamptz + +-- | Postgres enum declared with 'enum_'. +enumField :: Text -> Text -> FieldSpec +enumField name enumName = typedField (IR.TyEnum enumName) name + +typedField :: IR.FieldType -> Text -> FieldSpec +typedField ty name = + IR.field name ty & column (camelToSnake name) + +-- | Override the Postgres column name (@text \"title\" & column \"heading\"@). +column :: Text -> FieldSpec -> FieldSpec +column = IR.column + +-- | @hasMany \"posts\" \"Post\" \"authorId\"@: the other table's @authorId@ points at this model's PK. +-- The include and nested-write field is that relation name (@posts@). +-- Include values are @skip@, @load@, or @loadWith@ on a nested include. +-- Record-update @where_@, @orderBy_@, and @take_@ on @load@ or @loadWith@ +-- to filter that relation. @take_@ is per parent. +hasMany :: + Text -> + Text -> + Text -> + RelationSpec +hasMany name toModel = IR.hasMany name "" toModel "id" + +-- | @belongsTo \"author\" \"Author\" \"authorId\"@: this model's @authorId@ points at @Author@'s PK. +belongsTo :: Text -> Text -> Text -> RelationSpec +belongsTo name toModel foreignFld = IR.belongsTo name "" toModel foreignFld "id" diff --git a/src/Poppy/Codegen/Target.hs b/src/Poppy/Codegen/Target.hs new file mode 100644 --- /dev/null +++ b/src/Poppy/Codegen/Target.hs @@ -0,0 +1,159 @@ +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} + +module Poppy.Codegen.Target + ( simpleTarget, + CodegenTarget, + GenOutput (..), + targetOutputs, + targetSchemas, + ) +where + +import Data.Char (isAlphaNum, isUpper) +import Data.Maybe (isNothing) +import Data.Text (Text) +import qualified Data.Text as T +import Poppy.Codegen.Emit.Client + ( emitClientModule, + ) +import Poppy.Codegen.Emit.Include (emitIncludeModule) +import Poppy.Codegen.Emit.Schema (emitEnumModule, emitModelModule) +import Poppy.Codegen.IR + ( EnumSpec (..), + Model (..), + Schema (..), + enumImport, + enumName, + modelName, + modelRelations, + schemaEnums, + schemaModels, + ) +import System.FilePath (dropTrailingPathSeparator, splitDirectories, ()) + +-- | Path is relative to the process working directory. +data GenOutput = GenOutput + { outputPath :: FilePath, + outputText :: Text + } + +data SchemaLayout = SchemaLayout + { slModulePrefix :: Text, + slOutputDir :: FilePath + } + +data ClientLayout = ClientLayout + { clModulePrefix :: Text, + clOutputDir :: FilePath + } + +data CodegenTarget = CodegenTarget + { ctSchemas :: [Schema], + ctLayout :: SchemaLayout, + ctClientLayout :: ClientLayout + } + +-- | Table types at @Prefix.Model@, clients at @Prefix.Client.Model@. +-- +-- @Prefix@ is the path with non-module segments dropped (@src/Schema@ → +-- @Schema@). +simpleTarget :: FilePath -> Schema -> CodegenTarget +simpleTarget dir schema = + let prefix = prefixFromDir dir + in CodegenTarget + { ctSchemas = [schema], + ctLayout = SchemaLayout (prefix <> ".") dir, + ctClientLayout = + ClientLayout + { clModulePrefix = prefix <> ".Client.", + clOutputDir = dir "Client" + } + } + +prefixFromDir :: FilePath -> Text +prefixFromDir dir = + case filter isModuleSegment (map T.pack (splitDirectories (dropTrailingPathSeparator dir))) of + [] -> + error $ + "simpleTarget: " + <> dir + <> " has no Haskell module segment (e.g. src/Schema)" + parts -> T.intercalate "." parts + +isModuleSegment :: Text -> Bool +isModuleSegment name = + case T.uncons name of + Just (c, rest) -> isUpper c && T.all isModuleChar rest + Nothing -> False + +isModuleChar :: Char -> Bool +isModuleChar c = isAlphaNum c || c == '_' || c == '\'' + +targetSchemas :: [CodegenTarget] -> [Schema] +targetSchemas = concatMap (.ctSchemas) + +targetOutputs :: CodegenTarget -> [GenOutput] +targetOutputs target = + concatMap (schemaOutputs target) target.ctSchemas + +schemaOutputs :: CodegenTarget -> Schema -> [GenOutput] +schemaOutputs target schema = + enumOutputs target schema + ++ modelOutputs target schema + ++ includeOutputs target schema + ++ clientOutputs target schema + +enumOutputs :: CodegenTarget -> Schema -> [GenOutput] +enumOutputs target schema = + concat + [ enumOutput target enum + | enum <- schemaEnums schema, + isNothing (enumImport enum) + ] + +enumOutput :: CodegenTarget -> EnumSpec -> [GenOutput] +enumOutput target enum = + let layout = target.ctLayout + name = enumName enum + moduleName = layout.slModulePrefix <> name + path = layout.slOutputDir T.unpack name <> ".hs" + in [gen path (emitEnumModule moduleName enum)] + +modelOutputs :: CodegenTarget -> Schema -> [GenOutput] +modelOutputs target schema = + concatMap (modelOutput target schema) (schemaModels schema) + +modelOutput :: CodegenTarget -> Schema -> Model -> [GenOutput] +modelOutput target schema model = + let layout = target.ctLayout + name = modelName model + moduleName = layout.slModulePrefix <> name + path = layout.slOutputDir T.unpack name <> ".hs" + in [gen path (emitModelModule moduleName schema model)] + +includeOutputs :: CodegenTarget -> Schema -> [GenOutput] +includeOutputs target schema = + concatMap (includeOutput target schema) (filter (not . null . modelRelations) (schemaModels schema)) + +includeOutput :: CodegenTarget -> Schema -> Model -> [GenOutput] +includeOutput target schema model = + let layout = target.ctLayout + name = modelName model + moduleName = layout.slModulePrefix <> "Include." <> name + path = layout.slOutputDir "Include" T.unpack name <> ".hs" + in [gen path (emitIncludeModule moduleName schema model)] + +clientOutputs :: CodegenTarget -> Schema -> [GenOutput] +clientOutputs target schema = + concatMap (clientOutput target.ctClientLayout schema) (schemaModels schema) + +clientOutput :: ClientLayout -> Schema -> Model -> [GenOutput] +clientOutput layout schema model = + let name = modelName model + moduleName = layout.clModulePrefix <> name + path = layout.clOutputDir T.unpack name <> ".hs" + in [gen path (emitClientModule moduleName schema model)] + +gen :: FilePath -> Text -> GenOutput +gen path text = GenOutput {outputPath = path, outputText = text} diff --git a/src/Poppy/Codegen/TextUtil.hs b/src/Poppy/Codegen/TextUtil.hs new file mode 100644 --- /dev/null +++ b/src/Poppy/Codegen/TextUtil.hs @@ -0,0 +1,28 @@ +module Poppy.Codegen.TextUtil + ( lowerFirst, + upperFirst, + camelToSnake, + ) +where + +import Data.Char (isUpper, toLower, toUpper) +import Data.Text (Text) +import qualified Data.Text as T + +lowerFirst :: Text -> Text +lowerFirst t = case T.uncons t of + Nothing -> t + Just (c, rest) -> T.cons (toLower c) rest + +upperFirst :: Text -> Text +upperFirst t = case T.uncons t of + Nothing -> t + Just (c, rest) -> T.cons (toUpper c) rest + +camelToSnake :: Text -> Text +camelToSnake = + T.dropWhile (== '_') . T.concatMap step + where + step c + | isUpper c = T.pack ['_', toLower c] + | otherwise = T.singleton c diff --git a/src/Poppy/Codegen/Validate.hs b/src/Poppy/Codegen/Validate.hs new file mode 100644 --- /dev/null +++ b/src/Poppy/Codegen/Validate.hs @@ -0,0 +1,132 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Poppy.Codegen.Validate + ( ValidationError (..), + validateSchema, + ) +where + +import Data.List (find, nub) +import Data.Maybe (catMaybes, isNothing) +import Data.Text (Text) +import Poppy.Codegen.IR + +data ValidationError + = DuplicateModelName Text + | DuplicateEnumName Text + | EnumHasNoVariants Text + | DuplicateEnumVariant Text Text + | UnknownEnumType Text Text Text + | ModelMissingPrimaryKey Text + | ModelMultiplePrimaryKeys Text + | UnknownRelationModel Text Text Text + | UnknownRelationField Text Text Text + | DuplicateRelationName Text Text + | RelationNameClashesWithField Text Text + | UnknownUniqueModel Text + | UnknownUniqueField Text Text + | EmptyUniqueConstraint Text + deriving (Show, Eq) + +validateSchema :: Schema -> [ValidationError] +validateSchema schema = + concat + [ duplicateModelNames schema, + duplicateEnumNames schema, + concatMap validateEnum (schemaEnums schema), + concatMap (validateModel schema) (schemaModels schema), + concatMap (validateRelation schema) (concatMap modelRelations (schemaModels schema)), + concatMap (validateUnique schema) (schemaUniques schema) + ] + +duplicateModelNames :: Schema -> [ValidationError] +duplicateModelNames schema = + map DuplicateModelName (duplicates (map modelName (schemaModels schema))) + +duplicateEnumNames :: Schema -> [ValidationError] +duplicateEnumNames schema = + map DuplicateEnumName (duplicates (map enumName (schemaEnums schema))) + +validateEnum :: EnumSpec -> [ValidationError] +validateEnum enumSpec = + let emptyErr = + [EnumHasNoVariants (enumName enumSpec) | null (enumVariants enumSpec)] + dupVars = + map + (DuplicateEnumVariant (enumName enumSpec)) + (duplicates (map variantName (enumVariants enumSpec))) + in emptyErr ++ dupVars + +validateModel :: Schema -> Model -> [ValidationError] +validateModel schema model = + let pks = filter fieldIsPrimaryKey (modelFields model) + pkErrs = case pks of + [] -> [ModelMissingPrimaryKey (modelName model)] + [_] -> [] + _ -> [ModelMultiplePrimaryKeys (modelName model)] + enumErrs = concatMap (validateFieldEnum schema (modelName model)) (modelFields model) + in pkErrs ++ enumErrs ++ validateRelationNames model + +validateRelationNames :: Model -> [ValidationError] +validateRelationNames model = + map (DuplicateRelationName (modelName model)) (duplicates (map relName (modelRelations model))) + ++ [ RelationNameClashesWithField (modelName model) name + | rel <- modelRelations model, + let name = relName rel, + any ((== name) . fieldName) (modelFields model) + ] + +validateFieldEnum :: Schema -> Text -> FieldSpec -> [ValidationError] +validateFieldEnum schema modelName fieldSpec = + case fieldType fieldSpec of + TyEnum wanted -> + ([UnknownEnumType modelName (fieldName fieldSpec) wanted | not (any ((== wanted) . enumName) (schemaEnums schema))]) + _ -> [] + +validateRelation :: Schema -> RelationSpec -> [ValidationError] +validateRelation schema rel = + let fromOk = findModel schema (relFromModel rel) + toOk = findModel schema (relToModel rel) + modelErrs = + catMaybes + [ if isNothing fromOk + then Just (UnknownRelationModel (relName rel) "from" (relFromModel rel)) + else Nothing, + if isNothing toOk + then Just (UnknownRelationModel (relName rel) "to" (relToModel rel)) + else Nothing + ] + fieldErrs = case (fromOk, toOk, relKind rel) of + (Just fromModel, Just toModel, RelHasMany) -> + requireField (relName rel) (modelName fromModel) (relLocalField rel) fromModel + ++ requireField (relName rel) (modelName toModel) (relForeignField rel) toModel + (Just fromModel, Just toModel, RelBelongsTo) -> + requireField (relName rel) (modelName fromModel) (relForeignField rel) fromModel + ++ requireField (relName rel) (modelName toModel) (relLocalField rel) toModel + _ -> [] + in modelErrs ++ fieldErrs + +findModel :: Schema -> Text -> Maybe Model +findModel schema name = + find ((== name) . modelName) (schemaModels schema) + +validateUnique :: Schema -> UniqueConstraint -> [ValidationError] +validateUnique schema UniqueConstraint {uniqueModel, uniqueFields} = + case findModel schema uniqueModel of + Nothing -> + [UnknownUniqueModel uniqueModel] + Just model + | null uniqueFields -> + [EmptyUniqueConstraint uniqueModel] + | otherwise -> + [ UnknownUniqueField uniqueModel wanted + | wanted <- uniqueFields, + not (any ((== wanted) . fieldName) (modelFields model)) + ] + +requireField :: Text -> Text -> Text -> Model -> [ValidationError] +requireField relName modelName wantedField model = + [UnknownRelationField relName modelName wantedField | not (any ((== wantedField) . fieldName) (modelFields model))] + +duplicates :: (Eq a) => [a] -> [a] +duplicates xs = nub [x | x <- xs, length (filter (== x) xs) > 1] diff --git a/test/Poppy/Codegen/DriftSpec.hs b/test/Poppy/Codegen/DriftSpec.hs new file mode 100644 --- /dev/null +++ b/test/Poppy/Codegen/DriftSpec.hs @@ -0,0 +1,312 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Poppy.Codegen.DriftSpec + ( driftSpec, + driftDbSpec, + ) +where + +import Data.Function ((&)) +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import Data.Text (Text) +import Poppy.Codegen.Drift +import Poppy.Codegen.IR (FieldDefault (..), Schema (..), schemaUniques) +import Poppy.Codegen.Introspect (canonicalizeColumnType, introspectCatalog) +import qualified Poppy.Codegen.Schema as Builder +import Poppy.Codegen.Spec.Author (authorSchema) +import Poppy.Codegen.Spec.Flag (flagSchema) +import Poppy.Codegen.Spec.Packet (packetSchema) +import Poppy.Codegen.Spec.Shelf (shelfSchema) +import Poppy.Codegen.Spec.Widget (widgetSchema) +import Poppy.Internal.Db (withConn) +import Support.TestDb (TestEnv (..)) +import Test.Hspec + +driftSpec :: Spec +driftSpec = + describe "Poppy.Codegen.Drift" $ do + it "accepts an IR that matches the catalog" $ + checkSchema widgetSchema (widgetCatalog False) `shouldBe` [] + + it "reports a missing table" $ + checkSchema widgetSchema emptyCatalog + `shouldBe` [DriftMissingTable "Widget" "test_widget"] + + it "reports nullability drift" $ + checkSchema widgetSchema (widgetCatalog True) + `shouldBe` [DriftNullability "test_widget" "name" False True] + + it "reports a missing unique from the IR" $ + checkSchema widgetSchema widgetCatalogWithoutUnique + `shouldBe` [DriftMissingUnique "test_widget" ["name"]] + + it "reports a database unique that is not in the IR" $ + checkSchema widgetSchemaWithoutNameUnique (widgetCatalog False) + `shouldBe` [DriftUnexpectedUnique "test_widget" ["name"]] + + it "reports enum label drift" $ + checkSchema colorSchema colorCatalogWrongLabels + `shouldBe` [DriftEnumLabels "Color" ["blue", "green", "red"] ["blue", "red"]] + + it "accepts a boolean column that matches the catalog" $ + checkSchema flagSchema flagCatalog `shouldBe` [] + + it "reports type drift on a boolean column" $ + checkSchema flagSchema flagCatalogAsText + `shouldBe` [DriftType "flag" "active" "boolean" "text"] + + it "canonicalizes Postgres boolean to the IR boolean type" $ + canonicalizeColumnType "boolean" "bool" `shouldBe` "boolean" + + it "canonicalizes Postgres numeric and jsonb" $ do + canonicalizeColumnType "numeric" "numeric" `shouldBe` "numeric" + canonicalizeColumnType "jsonb" "jsonb" `shouldBe` "jsonb" + + it "accepts numeric and jsonb columns that match the catalog" $ + checkSchema packetSchema packetCatalog `shouldBe` [] + + it "reports type drift on a numeric column" $ + checkSchema packetSchema packetCatalogAmountAsInt + `shouldBe` [DriftType "test_packet" "amount" "numeric" "int"] + + it "reports a missing column DEFAULT" $ + checkSchema widgetSchema (widgetCatalogWithoutIdDefault) + `shouldBe` [DriftMissingDefault "test_widget" "id" DefaultUuidV4] + + it "reports a mismatched column DEFAULT" $ + checkSchema widgetSchema (widgetCatalogWithNowOnId) + `shouldBe` [DriftDefaultMismatch "test_widget" "id" DefaultUuidV4 "now()"] + + it "reports a missing foreign key implied by belongsTo" $ + checkSchema authorSchema authorCatalogNoFk + `shouldBe` [DriftMissingForeignKey "test_post" "author_id" "test_author" "id"] + + it "reports a missing foreign key implied by hasMany" $ + checkSchema shelfSchema (shelfCatalogNoFk) + `shouldBe` [ DriftMissingForeignKey "test_book" "shelf_id" "test_shelf" "id", + DriftMissingForeignKey "test_tag" "shelf_id" "test_shelf" "id", + DriftMissingForeignKey "test_chapter" "book_id" "test_book" "id", + DriftMissingForeignKey "test_section" "chapter_id" "test_chapter" "id" + ] + +driftDbSpec :: SpecWith TestEnv +driftDbSpec = + describe "Poppy.Codegen.Drift against Postgres" $ do + it "matches widget, shelf, author, and packet IR to the test database" $ \TestEnv {envPool = pool} -> do + catalog <- withConn pool introspectCatalog + checkSchema widgetSchema catalog `shouldBe` [] + checkSchema shelfSchema catalog `shouldBe` [] + checkSchema authorSchema catalog `shouldBe` [] + checkSchema packetSchema catalog `shouldBe` [] + +widgetSchemaWithoutNameUnique :: Schema +widgetSchemaWithoutNameUnique = + widgetSchema {schemaUniques = []} + +widgetCatalog :: Bool -> DbCatalog +widgetCatalog nameNullable = + emptyCatalog + { dbTables = + Map.singleton + "test_widget" + DbTable + { dbTableName = "test_widget", + dbColumns = + Map.fromList + [ col "id" "uuid" False (Just "uuid_generate_v4()"), + col "created_at" "timestamptz" False (Just "CURRENT_TIMESTAMP"), + col "updated_at" "timestamptz" False (Just "CURRENT_TIMESTAMP"), + col "name" "text" nameNullable Nothing, + col "description" "text" True Nothing + ], + dbPrimaryKey = ["id"], + dbUniques = [Set.singleton "name"] + } + } + +widgetCatalogWithoutUnique :: DbCatalog +widgetCatalogWithoutUnique = + let base = widgetCatalog False + table = dbTables base Map.! "test_widget" + in base {dbTables = Map.singleton "test_widget" table {dbUniques = []}} + +widgetCatalogWithoutIdDefault :: DbCatalog +widgetCatalogWithoutIdDefault = + setWidgetIdDefault Nothing + +widgetCatalogWithNowOnId :: DbCatalog +widgetCatalogWithNowOnId = + setWidgetIdDefault (Just "now()") + +setWidgetIdDefault :: Maybe Text -> DbCatalog +setWidgetIdDefault mDefault = + let base = widgetCatalog False + table = dbTables base Map.! "test_widget" + idCol = dbColumns table Map.! "id" + in base + { dbTables = + Map.singleton + "test_widget" + table {dbColumns = Map.insert "id" idCol {dbColDefault = mDefault} (dbColumns table)} + } + +colorSchema :: Schema +colorSchema = + Builder.schema + [Builder.enum_ "Color" [Builder.variant "red", Builder.variant "blue", Builder.variant "green"]] + [ Builder.model + "Swatch" + [ Builder.uuid "id" & Builder.pk, + Builder.enumField "color" "Color" + ] + [] + ] + [] + +colorCatalogWrongLabels :: DbCatalog +colorCatalogWrongLabels = + emptyCatalog + { dbEnums = Map.singleton "color" ["red", "blue"], + dbTables = + Map.singleton + "swatch" + DbTable + { dbTableName = "swatch", + dbColumns = + Map.fromList + [ col "id" "uuid" False Nothing, + col "color" "enum:color" False Nothing + ], + dbPrimaryKey = ["id"], + dbUniques = [] + } + } + +flagCatalog :: DbCatalog +flagCatalog = + emptyCatalog + { dbTables = + Map.singleton + "flag" + DbTable + { dbTableName = "flag", + dbColumns = + Map.fromList + [ col "id" "uuid" False (Just "uuid_generate_v4()"), + col "active" "boolean" False Nothing + ], + dbPrimaryKey = ["id"], + dbUniques = [] + } + } + +flagCatalogAsText :: DbCatalog +flagCatalogAsText = + let table = dbTables flagCatalog Map.! "flag" + active = dbColumns table Map.! "active" + in flagCatalog + { dbTables = + Map.singleton + "flag" + table {dbColumns = Map.insert "active" active {dbColType = "text"} (dbColumns table)} + } + +packetCatalog :: DbCatalog +packetCatalog = + emptyCatalog + { dbTables = + Map.singleton + "test_packet" + DbTable + { dbTableName = "test_packet", + dbColumns = + Map.fromList + [ col "id" "uuid" False (Just "uuid_generate_v4()"), + col "amount" "numeric" False Nothing, + col "payload" "jsonb" False Nothing + ], + dbPrimaryKey = ["id"], + dbUniques = [] + } + } + +packetCatalogAmountAsInt :: DbCatalog +packetCatalogAmountAsInt = + let table = dbTables packetCatalog Map.! "test_packet" + amount = dbColumns table Map.! "amount" + in packetCatalog + { dbTables = + Map.singleton + "test_packet" + table {dbColumns = Map.insert "amount" amount {dbColType = "int"} (dbColumns table)} + } + +col :: Text -> Text -> Bool -> Maybe Text -> (Text, DbColumn) +col name ty isNullable mDefault = + ( name, + DbColumn + { dbColName = name, + dbColType = ty, + dbColNullable = isNullable, + dbColDefault = mDefault + } + ) + +authorCatalogNoFk :: DbCatalog +authorCatalogNoFk = + emptyCatalog + { dbTables = + Map.fromList + [ ( "test_author", + DbTable + { dbTableName = "test_author", + dbColumns = + Map.fromList + [ col "id" "uuid" False (Just "uuid_generate_v4()"), + col "name" "text" False Nothing + ], + dbPrimaryKey = ["id"], + dbUniques = [] + } + ), + ( "test_post", + DbTable + { dbTableName = "test_post", + dbColumns = + Map.fromList + [ col "id" "uuid" False (Just "uuid_generate_v4()"), + col "author_id" "uuid" False Nothing, + col "title" "text" False Nothing, + col "status" "enum:poststatus" False Nothing + ], + dbPrimaryKey = ["id"], + dbUniques = [] + } + ) + ], + dbEnums = Map.singleton "poststatus" ["draft", "published"] + } + +shelfCatalogNoFk :: DbCatalog +shelfCatalogNoFk = + emptyCatalog + { dbTables = + Map.fromList + [ table "test_shelf" [col "id" "uuid" False (Just "uuid_generate_v4()"), col "name" "text" False Nothing], + table "test_book" [col "id" "uuid" False (Just "uuid_generate_v4()"), col "shelf_id" "uuid" False Nothing, col "title" "text" False Nothing], + table "test_chapter" [col "id" "uuid" False (Just "uuid_generate_v4()"), col "book_id" "uuid" False Nothing, col "heading" "text" False Nothing], + table "test_section" [col "id" "uuid" False (Just "uuid_generate_v4()"), col "chapter_id" "uuid" False Nothing, col "label" "text" False Nothing], + table "test_tag" [col "id" "uuid" False (Just "uuid_generate_v4()"), col "shelf_id" "uuid" False Nothing, col "label" "text" False Nothing] + ] + } + where + table name columns = + ( name, + DbTable + { dbTableName = name, + dbColumns = Map.fromList columns, + dbPrimaryKey = ["id"], + dbUniques = [] + } + ) diff --git a/test/Poppy/Codegen/EmitClientSpec.hs b/test/Poppy/Codegen/EmitClientSpec.hs new file mode 100644 --- /dev/null +++ b/test/Poppy/Codegen/EmitClientSpec.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Poppy.Codegen.EmitClientSpec + ( emitClientSpec, + ) +where + +import qualified Data.Text as T +import qualified Data.Text.IO as TIO +import Poppy.Codegen.Emit.Client + ( emitClientModule, + emitSimpleClientModule, + ) +import Poppy.Codegen.IR + ( modelName, + schemaModels, + ) +import Poppy.Codegen.Schema + ( FieldDefault (..), + Schema, + hasMany, + model, + nullable, + pk, + schema, + text, + timestamptz, + uuid, + withDefault, + (&), + ) +import Poppy.Codegen.Spec.Example (exampleSchema, taskModel) +import Poppy.Codegen.Spec.Shelf (shelfSchema) +import Test.Hspec + +emitClientSpec :: Spec +emitClientSpec = + describe "Poppy.Codegen.Emit.Client" $ do + it "emits Client for the canonical Example Task model" $ do + let actual = emitSimpleClientModule "Poppy.Client.Task" exampleSchema taskModel + actual `shouldSatisfy` T.isInfixOf "data TaskQuery" + actual `shouldSatisfy` T.isInfixOf "findMany :: TaskQuery" + actual `shouldSatisfy` T.isInfixOf "findFirst :: TaskQuery" + actual `shouldSatisfy` T.isInfixOf "count :: TaskQuery" + actual `shouldSatisfy` T.isInfixOf "createMany ::" + actual `shouldSatisfy` T.isInfixOf "updateMany ::" + actual `shouldSatisfy` T.isInfixOf "upsert ::" + actual `shouldSatisfy` T.isInfixOf "emptyQuery" + actual `shouldSatisfy` T.isInfixOf "data TaskUniqueQuery" + actual `shouldSatisfy` T.isInfixOf "uniqueQuery ::" + + it "emits Shelf Client with include_ and writes" $ do + expected <- TIO.readFile "test/Poppy/Codegen/golden/ShelfReadClient.hs.golden" + let shelf = head [m | m <- schemaModels shelfSchema, modelName m == "Shelf"] + actual = emitClientModule "Schema.Client.Shelf" shelfSchema shelf + T.strip actual `shouldBe` T.strip expected + actual `shouldSatisfy` T.isInfixOf "create ::" + actual `shouldSatisfy` T.isInfixOf "createMany ::" + actual `shouldSatisfy` T.isInfixOf "updateMany ::" + actual `shouldSatisfy` T.isInfixOf "upsert ::" + actual `shouldSatisfy` T.isInfixOf "data BookNestedCreate" + actual `shouldSatisfy` T.isInfixOf "data BooksUpdate" + actual `shouldSatisfy` T.isInfixOf "replaceWith ::" + actual `shouldSatisfy` T.isInfixOf "ShelfCreateScalars" + actual `shouldSatisfy` T.isInfixOf "include_ :: include" + actual `shouldSatisfy` T.isInfixOf "include_ :: include" + + it "imports root scalar types on nested-write Clients" $ do + let recipe = head [m | m <- schemaModels recipeNestedSchema, modelName m == "Recipe"] + actual = emitClientModule "Schema.Client.Recipe" recipeNestedSchema recipe + actual `shouldSatisfy` T.isInfixOf "import Data.Time (UTCTime)" + actual `shouldSatisfy` T.isInfixOf "NullableValue (..)" + actual `shouldSatisfy` T.isInfixOf "createdAt :: Maybe UTCTime" + actual `shouldSatisfy` T.isInfixOf "description :: NullableValue Text" + +-- Parent with hasMany plus root timestamptz / nullable text (Recipe-shaped). +recipeNestedSchema :: Schema +recipeNestedSchema = + schema + [] + [ model + "Recipe" + [ uuid "id" & pk & withDefault DefaultUuidV4, + timestamptz "createdAt" & withDefault DefaultNow, + text "title", + text "description" & nullable + ] + [hasMany "steps" "Step" "recipeId"], + model + "Step" + [ uuid "id" & pk & withDefault DefaultUuidV4, + uuid "recipeId", + text "body" + ] + [] + ] + [] diff --git a/test/Poppy/Codegen/EmitIncludeSpec.hs b/test/Poppy/Codegen/EmitIncludeSpec.hs new file mode 100644 --- /dev/null +++ b/test/Poppy/Codegen/EmitIncludeSpec.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Poppy.Codegen.EmitIncludeSpec + ( emitIncludeSpec, + ) +where + +import qualified Data.Text as T +import Poppy.Codegen.Emit.Include (emitIncludeModule) +import Poppy.Codegen.IR (modelName, schemaModels) +import Poppy.Codegen.Spec.Shelf (shelfSchema) +import Test.Hspec + +emitIncludeSpec :: Spec +emitIncludeSpec = + describe "Poppy.Codegen.Emit.Include" $ do + it "emits one Shelf include module with uniform edges" $ do + let shelf = head [m | m <- schemaModels shelfSchema, modelName m == "Shelf"] + actual = emitIncludeModule "Schema.Include.Shelf" shelfSchema shelf + actual `shouldSatisfy` T.isInfixOf "module Schema.Include.Shelf" + actual `shouldSatisfy` T.isInfixOf "data ShelfInclude books tags" + actual `shouldSatisfy` T.isInfixOf "ShelfBooks Skip = Skipped \"books\"" + actual `shouldSatisfy` T.isInfixOf "Load BookTable" + actual `shouldSatisfy` T.isInfixOf "edge.where_" + actual `shouldSatisfy` T.isInfixOf "edge.take_" + actual `shouldSatisfy` T.isInfixOf "loadShelf" + actual `shouldSatisfy` T.isInfixOf "IncludeFor \"Shelf\"" diff --git a/test/Poppy/Codegen/EmitSpec.hs b/test/Poppy/Codegen/EmitSpec.hs new file mode 100644 --- /dev/null +++ b/test/Poppy/Codegen/EmitSpec.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Poppy.Codegen.EmitSpec + ( emitSpec, + ) +where + +import Data.List (find) +import qualified Data.Text as T +import qualified Data.Text.IO as T +import Poppy.Codegen.Emit.Schema (emitModelModule) +import Poppy.Codegen.IR + ( Model (..), + modelName, + schemaModels, + ) +import Poppy.Codegen.Spec.Example (exampleSchema, taskModel) +import Poppy.Codegen.Spec.Flag (flagModel, flagSchema) +import Poppy.Codegen.Spec.Packet (packetModel, packetSchema) +import Poppy.Codegen.Spec.Shelf (shelfSchema) +import Poppy.Codegen.Spec.Widget (widgetModel, widgetSchema) +import Test.Hspec + +emitSpec :: Spec +emitSpec = do + describe "Poppy.Codegen.Emit.Schema" $ do + it "emits the canonical Example Task module" $ do + let actual = emitModelModule "Schema.Task" exampleSchema taskModel + actual `shouldSatisfy` T.isInfixOf "data TaskRow" + actual `shouldSatisfy` T.isInfixOf "done :: Bool" + actual `shouldSatisfy` T.isInfixOf "tableName = \"task\"" + + it "emits Widget matching the golden file" $ do + expected <- T.readFile "test/Poppy/Codegen/golden/Widget.hs.golden" + let actual = emitModelModule "Schema.Widget" widgetSchema widgetModel + T.strip actual `shouldBe` T.strip expected + + it "emits Flag matching the golden file" $ do + expected <- T.readFile "test/Poppy/Codegen/golden/Flag.hs.golden" + let actual = emitModelModule "Schema.Flag" flagSchema flagModel + T.strip actual `shouldBe` T.strip expected + + it "emits Packet matching the golden file" $ do + expected <- T.readFile "test/Poppy/Codegen/golden/Packet.hs.golden" + let actual = emitModelModule "Schema.Packet" packetSchema packetModel + T.strip actual `shouldBe` T.strip expected + + it "emits Shelf matching the golden file" $ do + expected <- T.readFile "test/Poppy/Codegen/golden/Shelf.hs.golden" + let actual = emitModelModule "Schema.Shelf" shelfSchema shelfModel + T.strip actual `shouldBe` T.strip expected + + it "emits Book matching the golden file" $ do + expected <- T.readFile "test/Poppy/Codegen/golden/Book.hs.golden" + let actual = emitModelModule "Schema.Book" shelfSchema bookModel + T.strip actual `shouldBe` T.strip expected + + it "emits Chapter matching the golden file" $ do + expected <- T.readFile "test/Poppy/Codegen/golden/Chapter.hs.golden" + let actual = emitModelModule "Schema.Chapter" shelfSchema chapterModel + T.strip actual `shouldBe` T.strip expected + +shelfModel :: Model +shelfModel = + case find ((== "Shelf") . modelName) (schemaModels shelfSchema) of + Just m -> m + Nothing -> error "shelfModel: Shelf missing" + +bookModel :: Model +bookModel = + case find ((== "Book") . modelName) (schemaModels shelfSchema) of + Just m -> m + Nothing -> error "bookModel: Book missing" + +chapterModel :: Model +chapterModel = + case find ((== "Chapter") . modelName) (schemaModels shelfSchema) of + Just m -> m + Nothing -> error "chapterModel: Chapter missing" diff --git a/test/Poppy/Codegen/SchemaSpec.hs b/test/Poppy/Codegen/SchemaSpec.hs new file mode 100644 --- /dev/null +++ b/test/Poppy/Codegen/SchemaSpec.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Poppy.Codegen.SchemaSpec + ( schemaSpec, + ) +where + +import Poppy.Codegen.IR (modelName, modelRelations, relName, schemaModels) +import Poppy.Codegen.Schema +import Poppy.Codegen.Spec.Editor (editorSchema) +import Poppy.Codegen.Spec.Shelf (shelfSchema) +import Test.Hspec + +schemaSpec :: Spec +schemaSpec = + describe "Poppy.Codegen.Schema" $ do + it "keeps relation names as declared" $ do + let parent = + model + "Parent" + [uuid "id" & pk] + [hasMany "kids" "Kid" "parentId"] + child = + model + "Kid" + [uuid "id" & pk, uuid "parentId"] + [] + built = schema [] [parent, child] [] + parentModel = head (schemaModels built) + map relName (modelRelations parentModel) `shouldBe` ["kids"] + + it "derives Shelf relations from the model" $ do + let shelf = head [m | m <- schemaModels shelfSchema, modelName m == "Shelf"] + map relName (modelRelations shelf) `shouldBe` ["books", "tags"] + + it "keeps two relations to the same model as distinct edges" $ do + let editor = head [m | m <- schemaModels editorSchema, modelName m == "Editor"] + map relName (modelRelations editor) `shouldBe` ["writtenPosts", "editedPosts"] diff --git a/test/Poppy/Codegen/Spec/Author.hs b/test/Poppy/Codegen/Spec/Author.hs new file mode 100644 --- /dev/null +++ b/test/Poppy/Codegen/Spec/Author.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Poppy.Codegen.Spec.Author + ( authorSchema, + authorModel, + postModel, + ) +where + +import Poppy.Codegen.Schema + +authorSchema :: Schema +authorSchema = + schema + [enum_ "PostStatus" [variant "Draft", variant "Published"]] + [authorModel, postModel] + [] + +authorModel :: Model +authorModel = + model + "Author" + [ uuid "id" & pk & withDefault DefaultUuidV4, + text "name" + ] + [hasMany "posts" "Post" "authorId"] + & table "test_author" + +postModel :: Model +postModel = + model + "Post" + [ uuid "id" & pk & withDefault DefaultUuidV4, + uuid "authorId", + text "title", + enumField "status" "PostStatus" + ] + [belongsTo "author" "Author" "authorId"] + & table "test_post" diff --git a/test/Poppy/Codegen/Spec/Comment.hs b/test/Poppy/Codegen/Spec/Comment.hs new file mode 100644 --- /dev/null +++ b/test/Poppy/Codegen/Spec/Comment.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Poppy.Codegen.Spec.Comment + ( commentSchema, + ) +where + +import Poppy.Codegen.Schema + +-- A comment can include its replies, and each reply can include its own. +commentSchema :: Schema +commentSchema = + schema + [] + [ commentModel + ] + [] + +commentModel :: Model +commentModel = + model + "Comment" + [ uuid "id" & pk & withDefault DefaultUuidV4, + uuid "parentId" & nullable, + text "body" + ] + [hasMany "replies" "Comment" "parentId"] + & table "test_comment" diff --git a/test/Poppy/Codegen/Spec/Editor.hs b/test/Poppy/Codegen/Spec/Editor.hs new file mode 100644 --- /dev/null +++ b/test/Poppy/Codegen/Spec/Editor.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Poppy.Codegen.Spec.Editor + ( editorSchema, + ) +where + +import Poppy.Codegen.Schema + +-- Two hasMany edges from one model to the same model. The names are the +-- include fields, so both relations compile. +editorSchema :: Schema +editorSchema = + schema + [] + [editorModel, articleModel] + [] + +editorModel :: Model +editorModel = + model + "Editor" + [ uuid "id" & pk & withDefault DefaultUuidV4, + text "name" + ] + [ hasMany "writtenPosts" "Article" "authorId", + hasMany "editedPosts" "Article" "authorId" + ] + & table "test_editor" + +articleModel :: Model +articleModel = + model + "Article" + [ uuid "id" & pk & withDefault DefaultUuidV4, + uuid "authorId", + text "title" + ] + [] + & table "test_article" diff --git a/test/Poppy/Codegen/Spec/Example.hs b/test/Poppy/Codegen/Spec/Example.hs new file mode 100644 --- /dev/null +++ b/test/Poppy/Codegen/Spec/Example.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Poppy.Codegen.Spec.Example + ( taskModel, + exampleSchema, + ) +where + +import Poppy.Codegen.Schema + +exampleSchema :: Schema +exampleSchema = + schema [] [taskModel] [] + +taskModel :: Model +taskModel = + model + "Task" + [ uuid "id" & pk & withDefault DefaultUuidV4, + timestamptz "createdAt" & withDefault DefaultNow, + timestamptz "updatedAt" & withDefault DefaultNow & updatedAt, + text "title", + bool "done" + ] + [] diff --git a/test/Poppy/Codegen/Spec/Flag.hs b/test/Poppy/Codegen/Spec/Flag.hs new file mode 100644 --- /dev/null +++ b/test/Poppy/Codegen/Spec/Flag.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Poppy.Codegen.Spec.Flag + ( flagModel, + flagSchema, + ) +where + +import Poppy.Codegen.Schema + +flagSchema :: Schema +flagSchema = + schema [] [flagModel] [] + +flagModel :: Model +flagModel = + model + "Flag" + [ uuid "id" & pk & withDefault DefaultUuidV4, + bool "active" + ] + [] diff --git a/test/Poppy/Codegen/Spec/Packet.hs b/test/Poppy/Codegen/Spec/Packet.hs new file mode 100644 --- /dev/null +++ b/test/Poppy/Codegen/Spec/Packet.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Poppy.Codegen.Spec.Packet + ( packetModel, + packetSchema, + ) +where + +import Poppy.Codegen.Schema + +packetSchema :: Schema +packetSchema = + schema [] [packetModel] [] + +packetModel :: Model +packetModel = + model + "Packet" + [ uuid "id" & pk & withDefault DefaultUuidV4, + numeric "amount", + jsonb "payload" + ] + [] + & table "test_packet" diff --git a/test/Poppy/Codegen/Spec/Shelf.hs b/test/Poppy/Codegen/Spec/Shelf.hs new file mode 100644 --- /dev/null +++ b/test/Poppy/Codegen/Spec/Shelf.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Poppy.Codegen.Spec.Shelf + ( shelfSchema, + ) +where + +import Poppy.Codegen.Schema + +shelfSchema :: Schema +shelfSchema = + schema + [] + [shelfModel, bookModel, chapterModel, sectionModel, tagModel] + [] + +shelfModel :: Model +shelfModel = + model + "Shelf" + [ uuid "id" & pk & withDefault DefaultUuidV4, + text "name" + ] + [ hasMany "books" "Book" "shelfId", + hasMany "tags" "Tag" "shelfId" + ] + & table "test_shelf" + +bookModel :: Model +bookModel = + model + "Book" + [ uuid "id" & pk & withDefault DefaultUuidV4, + uuid "shelfId", + text "title" + ] + [hasMany "chapters" "Chapter" "bookRef"] + & table "test_book" + +chapterModel :: Model +chapterModel = + model + "Chapter" + [ uuid "id" & pk & withDefault DefaultUuidV4, + uuid "bookRef" & column "book_id", + text "heading" + ] + [hasMany "sections" "Section" "chapterRef"] + & table "test_chapter" + +sectionModel :: Model +sectionModel = + model + "Section" + [ uuid "id" & pk & withDefault DefaultUuidV4, + uuid "chapterRef" & column "chapter_id", + text "label" + ] + [] + & table "test_section" + +tagModel :: Model +tagModel = + model + "Tag" + [ uuid "id" & pk & withDefault DefaultUuidV4, + uuid "shelfId", + text "label" + ] + [] + & table "test_tag" diff --git a/test/Poppy/Codegen/Spec/ShelfDeep.hs b/test/Poppy/Codegen/Spec/ShelfDeep.hs new file mode 100644 --- /dev/null +++ b/test/Poppy/Codegen/Spec/ShelfDeep.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Poppy.Codegen.Spec.ShelfDeep + ( shelfDeepSchema, + ) +where + +import Poppy.Codegen.IR (Schema) +import Poppy.Codegen.Spec.Shelf (shelfSchema) + +-- Same models as Shelf; includes are derived from relations only. +shelfDeepSchema :: Schema +shelfDeepSchema = shelfSchema diff --git a/test/Poppy/Codegen/Spec/Widget.hs b/test/Poppy/Codegen/Spec/Widget.hs new file mode 100644 --- /dev/null +++ b/test/Poppy/Codegen/Spec/Widget.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Poppy.Codegen.Spec.Widget + ( widgetModel, + widgetSchema, + ) +where + +import Poppy.Codegen.Schema + +widgetSchema :: Schema +widgetSchema = + schema [] [widgetModel] [unique_ "Widget" ["name"]] + +widgetModel :: Model +widgetModel = + model + "Widget" + [ uuid "id" & pk & withDefault DefaultUuidV4, + timestamptz "createdAt" & withDefault DefaultNow, + timestamptz "updatedAt" & withDefault DefaultNow & updatedAt, + text "name", + text "description" & nullable + ] + [] + & table "test_widget" diff --git a/test/Poppy/Codegen/TargetSpec.hs b/test/Poppy/Codegen/TargetSpec.hs new file mode 100644 --- /dev/null +++ b/test/Poppy/Codegen/TargetSpec.hs @@ -0,0 +1,152 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Poppy.Codegen.TargetSpec + ( targetSpec, + ) +where + +import Data.List (nub, sort) +import qualified Data.Text as T +import Poppy.Codegen.Run (allOutputs, schemasForTargets) +import Poppy.Codegen.Spec.Author (authorSchema) +import Poppy.Codegen.Spec.Comment (commentSchema) +import Poppy.Codegen.Spec.Editor (editorSchema) +import Poppy.Codegen.Spec.Shelf (shelfSchema) +import Poppy.Codegen.Spec.Widget (widgetSchema) +import Poppy.Codegen.Target + ( CodegenTarget, + GenOutput (..), + simpleTarget, + targetOutputs, + ) +import Poppy.Codegen.TestTarget (testTargets) +import Test.Hspec + +allTargets :: [CodegenTarget] +allTargets = testTargets + +schemaGoldenNames :: [FilePath] +schemaGoldenNames = + [ "Article", + "Author", + "Book", + "Chapter", + "Comment", + "Editor", + "Include/Author", + "Include/Book", + "Include/Chapter", + "Include/Comment", + "Include/Editor", + "Include/Post", + "Include/Shelf", + "Post", + "PostStatus", + "Section", + "Shelf", + "Tag", + "Widget" + ] + +targetSpec :: Spec +targetSpec = + describe "Poppy.Codegen.Target" $ do + it "validates every schema referenced by a target" $ do + schemasForTargets allTargets + `shouldMatchList` [ widgetSchema, + shelfSchema, + authorSchema, + editorSchema, + commentSchema + ] + + it "writes table types under the output dir and clients under Client/" $ do + let paths = sort (nub (map outputPath (allOutputs allTargets))) + filter (not . isClientPath) paths + `shouldBe` sort + [ "test/Schema/Article.hs", + "test/Schema/Author.hs", + "test/Schema/Book.hs", + "test/Schema/Chapter.hs", + "test/Schema/Comment.hs", + "test/Schema/Editor.hs", + "test/Schema/Include/Author.hs", + "test/Schema/Include/Book.hs", + "test/Schema/Include/Chapter.hs", + "test/Schema/Include/Comment.hs", + "test/Schema/Include/Editor.hs", + "test/Schema/Include/Post.hs", + "test/Schema/Include/Shelf.hs", + "test/Schema/Post.hs", + "test/Schema/PostStatus.hs", + "test/Schema/Section.hs", + "test/Schema/Shelf.hs", + "test/Schema/Tag.hs", + "test/Schema/Widget.hs" + ] + filter isClientPath paths + `shouldNotBe` [] + + it "keeps generated schema modules byte-stable" $ do + mapM_ assertGoldenStable schemaGoldenNames + + it "emits one Client per model" $ do + outputPaths (simpleTarget "src/Schema" shelfSchema) + `shouldMatchList` [ "src/Schema/Book.hs", + "src/Schema/Chapter.hs", + "src/Schema/Include/Book.hs", + "src/Schema/Include/Chapter.hs", + "src/Schema/Include/Shelf.hs", + "src/Schema/Section.hs", + "src/Schema/Shelf.hs", + "src/Schema/Tag.hs", + "src/Schema/Client/Book.hs", + "src/Schema/Client/Chapter.hs", + "src/Schema/Client/Section.hs", + "src/Schema/Client/Shelf.hs", + "src/Schema/Client/Tag.hs" + ] + + it "nests clients under the module prefix" $ do + let target = simpleTarget "src/Schema" widgetSchema + outputPaths target + `shouldMatchList` [ "src/Schema/Widget.hs", + "src/Schema/Client/Widget.hs" + ] + outputTextFor "src/Schema/Widget.hs" target + `shouldSatisfy` ("module Schema.Widget" `T.isInfixOf`) + outputTextFor "src/Schema/Client/Widget.hs" target + `shouldSatisfy` ("module Schema.Client.Widget" `T.isInfixOf`) + + it "keeps nested module prefixes from the path" $ do + outputPaths (simpleTarget "src/MyApp/Schema" widgetSchema) + `shouldMatchList` [ "src/MyApp/Schema/Widget.hs", + "src/MyApp/Schema/Client/Widget.hs" + ] + outputTextFor "src/MyApp/Schema/Widget.hs" (simpleTarget "src/MyApp/Schema" widgetSchema) + `shouldSatisfy` ("module MyApp.Schema.Widget" `T.isInfixOf`) + where + isClientPath path = "/Client/" `T.isInfixOf` T.pack path + + assertGoldenStable name = do + expected <- readFile ("test/Poppy/Codegen/golden/" <> name <> ".hs.golden") + let path = "test/Schema/" <> name <> ".hs" + actual = + T.unpack $ + outputText $ + head + [ out + | out <- allOutputs allTargets, + outputPath out == path + ] + actual `shouldBe` expected + + outputPaths target = map outputPath (targetOutputs target) + + outputTextFor path target = + outputText $ + head + [ out + | out <- targetOutputs target, + outputPath out == path + ] diff --git a/test/Poppy/Codegen/TestTarget.hs b/test/Poppy/Codegen/TestTarget.hs new file mode 100644 --- /dev/null +++ b/test/Poppy/Codegen/TestTarget.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Poppy.Codegen.TestTarget + ( testTargets, + ) +where + +import Poppy.Codegen.Spec.Author (authorSchema) +import Poppy.Codegen.Spec.Comment (commentSchema) +import Poppy.Codegen.Spec.Editor (editorSchema) +import Poppy.Codegen.Spec.Shelf (shelfSchema) +import Poppy.Codegen.Spec.Widget (widgetSchema) +import Poppy.Codegen.Target (CodegenTarget, simpleTarget) + +testTargets :: [CodegenTarget] +testTargets = + [ simpleTarget "test/Schema" widgetSchema, + simpleTarget "test/Schema" shelfSchema, + simpleTarget "test/Schema" authorSchema, + simpleTarget "test/Schema" editorSchema, + simpleTarget "test/Schema" commentSchema + ] diff --git a/test/Poppy/Codegen/ValidateSpec.hs b/test/Poppy/Codegen/ValidateSpec.hs new file mode 100644 --- /dev/null +++ b/test/Poppy/Codegen/ValidateSpec.hs @@ -0,0 +1,221 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Poppy.Codegen.ValidateSpec + ( validateSpec, + ) +where + +import Poppy.Codegen.IR +import qualified Poppy.Codegen.Schema as Builder +import Poppy.Codegen.Spec.Editor (editorSchema) +import Poppy.Codegen.Spec.Example (exampleSchema) +import Poppy.Codegen.Spec.Flag (flagSchema) +import Poppy.Codegen.Spec.Packet (packetSchema) +import Poppy.Codegen.Spec.Shelf (shelfSchema) +import Poppy.Codegen.Validate +import Test.Hspec + +emptySchema :: [Model] -> Schema +emptySchema models = + Schema {schemaEnums = [], schemaModels = models, schemaUniques = []} + +validateSpec :: Spec +validateSpec = + describe "Poppy.Codegen.Validate" $ do + describe "example specs" $ do + it "accepts the Shelf schema" $ + validateSchema shelfSchema `shouldBe` [] + + it "accepts the canonical Example schema" $ + validateSchema exampleSchema `shouldBe` [] + + it "accepts a Schema with a boolean field" $ + validateSchema flagSchema `shouldBe` [] + + it "accepts a Schema with numeric and jsonb fields" $ + validateSchema packetSchema `shouldBe` [] + + it "rejects a builder model with no primary key" $ + validateSchema (Builder.schema [] [Builder.model "Widget" [text "name"] []] []) + `shouldBe` [ModelMissingPrimaryKey "Widget"] + + describe "primary keys" $ do + it "rejects a model with no primary key" $ do + let schema = + emptySchema + [ Model + { modelName = "Widget", + modelTable = "widget", + modelFields = [text "name"], + modelRelations = [] + } + ] + validateSchema schema + `shouldBe` [ModelMissingPrimaryKey "Widget"] + + it "rejects a model with multiple primary keys" $ do + let schema = + emptySchema + [ Model + { modelName = "Widget", + modelTable = "widget", + modelFields = [pk (uuid "id"), pk (uuid "otherId")], + modelRelations = [] + } + ] + validateSchema schema + `shouldBe` [ModelMultiplePrimaryKeys "Widget"] + + describe "enums" $ do + it "rejects a field referencing an unknown enum" $ do + let schema = + emptySchema + [ Model + { modelName = "Item", + modelTable = "item", + modelFields = [pk (uuid "id"), enumField "unit" "Unit"], + modelRelations = [] + } + ] + validateSchema schema + `shouldBe` [UnknownEnumType "Item" "unit" "Unit"] + + it "rejects an enum with no variants" $ do + let schema = + Schema + { schemaEnums = [enum_ "Unit" []], + schemaModels = + [ Model + { modelName = "Item", + modelTable = "item", + modelFields = [pk (uuid "id")], + modelRelations = [] + } + ], + schemaUniques = [] + } + validateSchema schema + `shouldBe` [EnumHasNoVariants "Unit"] + + it "rejects duplicate enum variant names" $ do + let schema = + Schema + { schemaEnums = [enum_ "Unit" [variant "G", variant "G"]], + schemaModels = + [ Model + { modelName = "Item", + modelTable = "item", + modelFields = [pk (uuid "id")], + modelRelations = [] + } + ], + schemaUniques = [] + } + validateSchema schema + `shouldBe` [DuplicateEnumVariant "Unit" "G"] + + describe "relations" $ do + it "rejects a relation pointing at an unknown model" $ do + let schema = + emptySchema + [ Model + { modelName = "Shelf", + modelTable = "test_shelf", + modelFields = [pk (uuid "id")], + modelRelations = + [ hasMany "shelfBooks" "Shelf" "Missing" "id" "shelfId" + ] + } + ] + validateSchema schema + `shouldBe` [UnknownRelationModel "shelfBooks" "to" "Missing"] + + it "rejects a relation with an unknown field" $ do + let schema = + emptySchema + [ Model + { modelName = "Shelf", + modelTable = "test_shelf", + modelFields = [pk (uuid "id")], + modelRelations = + [ hasMany "shelfBooks" "Shelf" "Book" "id" "shelfId" + ] + }, + Model + { modelName = "Book", + modelTable = "test_book", + modelFields = [pk (uuid "id"), text "title"], + modelRelations = [] + } + ] + validateSchema schema + `shouldBe` [UnknownRelationField "shelfBooks" "Book" "shelfId"] + + it "rejects a relation name used twice on one model" $ do + let schema = + Builder.schema + [] + [ Builder.model + "Author" + [pk (uuid "id"), text "name"] + [ Builder.hasMany "posts" "Post" "authorId", + Builder.hasMany "posts" "Post" "authorId" + ], + Builder.model + "Post" + [pk (uuid "id"), uuid "authorId", text "title"] + [] + ] + [] + validateSchema schema + `shouldBe` [ DuplicateRelationName "Author" "posts" + ] + + it "rejects a relation name equal to a scalar field" $ do + let schema = + Builder.schema + [] + [ Builder.model + "Author" + [pk (uuid "id"), text "name"] + [Builder.hasMany "name" "Post" "authorId"], + Builder.model + "Post" + [pk (uuid "id"), uuid "authorId"] + [] + ] + [] + validateSchema schema + `shouldBe` [RelationNameClashesWithField "Author" "name"] + + it "accepts two relations from one model to the same model" $ do + validateSchema editorSchema `shouldBe` [] + + describe "uniques" $ do + it "rejects a unique constraint on an unknown model" $ do + let schema = + emptySchema + [ Model + { modelName = "Widget", + modelTable = "widget", + modelFields = [pk (uuid "id")], + modelRelations = [] + } + ] + drifted = schema {schemaUniques = [unique_ "Nope" ["id"]]} + validateSchema drifted + `shouldBe` [UnknownUniqueModel "Nope"] + + it "rejects a unique constraint that references an unknown field" $ do + let schema = + emptySchema + [ Model + { modelName = "Widget", + modelTable = "widget", + modelFields = [pk (uuid "id")], + modelRelations = [] + } + ] + drifted = schema {schemaUniques = [unique_ "Widget" ["name"]]} + validateSchema drifted + `shouldBe` [UnknownUniqueField "Widget" "name"] diff --git a/test/Poppy/Codegen/golden/Article.hs.golden b/test/Poppy/Codegen/golden/Article.hs.golden new file mode 100644 --- /dev/null +++ b/test/Poppy/Codegen/golden/Article.hs.golden @@ -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/Poppy/Codegen/golden/Author.hs.golden b/test/Poppy/Codegen/golden/Author.hs.golden new file mode 100644 --- /dev/null +++ b/test/Poppy/Codegen/golden/Author.hs.golden @@ -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/Poppy/Codegen/golden/Book.hs.golden b/test/Poppy/Codegen/golden/Book.hs.golden new file mode 100644 --- /dev/null +++ b/test/Poppy/Codegen/golden/Book.hs.golden @@ -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/Poppy/Codegen/golden/Chapter.hs.golden b/test/Poppy/Codegen/golden/Chapter.hs.golden new file mode 100644 --- /dev/null +++ b/test/Poppy/Codegen/golden/Chapter.hs.golden @@ -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/Poppy/Codegen/golden/Comment.hs.golden b/test/Poppy/Codegen/golden/Comment.hs.golden new file mode 100644 --- /dev/null +++ b/test/Poppy/Codegen/golden/Comment.hs.golden @@ -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/Poppy/Codegen/golden/Editor.hs.golden b/test/Poppy/Codegen/golden/Editor.hs.golden new file mode 100644 --- /dev/null +++ b/test/Poppy/Codegen/golden/Editor.hs.golden @@ -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/Poppy/Codegen/golden/Flag.hs.golden b/test/Poppy/Codegen/golden/Flag.hs.golden new file mode 100644 --- /dev/null +++ b/test/Poppy/Codegen/golden/Flag.hs.golden @@ -0,0 +1,136 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NoFieldSelectors #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE TypeApplications #-} + +module Schema.Flag + ( FlagTable (..), + FlagRow (..), + FlagSelect (..), + FlagPicked (..), + flagSelect, + flagSelectColumns, + parseFlagPicked, + toFlagPicked, + FlagCreate (..), + FlagUpdate (..), + flagId, + flagActive + ) +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 FlagTable = FlagTable + +type instance PrimaryKeyType FlagTable = UUID + +type instance ModelTable "Flag" = FlagTable + +instance Entity FlagTable where + tableName = "flag" + primaryKey = flagId + tableColumns = ["id", "active"] + +instance Insertable FlagTable where + type CreateInput FlagTable = FlagCreate + toInsertBuilder input = + setMaybe flagId input.id $ + set flagActive input.active $ + emptyInsert @FlagTable + + +instance Updatable FlagTable where + type UpdateInput FlagTable = FlagUpdate + updatedAtField = Nothing + toUpdateBuilder input = + setFieldMaybe flagActive input.active $ + emptyUpdate @FlagTable + + +data FlagRow = FlagRow + { id :: UUID, + active :: Bool + } + deriving (Show, Eq) + + +data FlagCreate = FlagCreate + { id :: Maybe UUID, + active :: Bool + } + deriving (Show, Eq) + + +data FlagUpdate = FlagUpdate + { active :: Maybe Bool + } + deriving (Show, Eq) + + +instance FromRow FlagRow where + fromRow = FlagRow <$> field <*> field + + +data FlagSelect = FlagSelect + { id :: Bool, + active :: Bool + } + deriving (Show, Eq) +data FlagPicked = FlagPicked + { id :: UUID, + active :: Picked Bool + } + deriving (Show, Eq) +flagSelect :: FlagSelect +flagSelect = + FlagSelect + { id = False, + active = False + } +flagSelectColumns :: FlagSelect -> [Text] +flagSelectColumns select_ = + fieldColumn flagId + : concat + [ [fieldColumn flagActive | select_.active] + ] +parseFlagPicked :: FlagSelect -> RowParser FlagPicked +parseFlagPicked select_ = do + idVal <- field + activeVal <- if select_.active then Picked <$> field else pure Skipped + pure FlagPicked { id = idVal, active = activeVal } +toFlagPicked :: FlagSelect -> FlagRow -> FlagPicked +toFlagPicked select_ row = + FlagPicked + { id = row.id, + active = picked select_.active row.active + } + + +flagId :: Field FlagTable UUID +flagId = Field "id" "id" + +flagActive :: Field FlagTable Bool +flagActive = Field "active" "active" + diff --git a/test/Poppy/Codegen/golden/Packet.hs.golden b/test/Poppy/Codegen/golden/Packet.hs.golden new file mode 100644 --- /dev/null +++ b/test/Poppy/Codegen/golden/Packet.hs.golden @@ -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/Poppy/Codegen/golden/Post.hs.golden b/test/Poppy/Codegen/golden/Post.hs.golden new file mode 100644 --- /dev/null +++ b/test/Poppy/Codegen/golden/Post.hs.golden @@ -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/Poppy/Codegen/golden/PostStatus.hs.golden b/test/Poppy/Codegen/golden/PostStatus.hs.golden new file mode 100644 --- /dev/null +++ b/test/Poppy/Codegen/golden/PostStatus.hs.golden @@ -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/Poppy/Codegen/golden/Section.hs.golden b/test/Poppy/Codegen/golden/Section.hs.golden new file mode 100644 --- /dev/null +++ b/test/Poppy/Codegen/golden/Section.hs.golden @@ -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/Poppy/Codegen/golden/Shelf.hs.golden b/test/Poppy/Codegen/golden/Shelf.hs.golden new file mode 100644 --- /dev/null +++ b/test/Poppy/Codegen/golden/Shelf.hs.golden @@ -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/Poppy/Codegen/golden/ShelfReadClient.hs.golden b/test/Poppy/Codegen/golden/ShelfReadClient.hs.golden new file mode 100644 --- /dev/null +++ b/test/Poppy/Codegen/golden/ShelfReadClient.hs.golden @@ -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/Poppy/Codegen/golden/Tag.hs.golden b/test/Poppy/Codegen/golden/Tag.hs.golden new file mode 100644 --- /dev/null +++ b/test/Poppy/Codegen/golden/Tag.hs.golden @@ -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/Poppy/Codegen/golden/Widget.hs.golden b/test/Poppy/Codegen/golden/Widget.hs.golden new file mode 100644 --- /dev/null +++ b/test/Poppy/Codegen/golden/Widget.hs.golden @@ -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,22 @@ +module Main (main) where + +import Poppy.Codegen.DriftSpec (driftDbSpec, driftSpec) +import Poppy.Codegen.EmitClientSpec (emitClientSpec) +import Poppy.Codegen.EmitIncludeSpec (emitIncludeSpec) +import Poppy.Codegen.EmitSpec (emitSpec) +import Poppy.Codegen.SchemaSpec (schemaSpec) +import Poppy.Codegen.TargetSpec (targetSpec) +import Poppy.Codegen.ValidateSpec (validateSpec) +import Support.TestDb (withTestDb) +import Test.Hspec + +main :: IO () +main = hspec $ do + schemaSpec + validateSpec + emitSpec + emitIncludeSpec + emitClientSpec + targetSpec + driftSpec + withTestDb driftDbSpec 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,66 @@ +{-# LANGUAGE TypeApplications #-} + +module Support.TestDb + ( TestEnv (..), + withTestDb, + testDatabaseUrl, + ) +where + +import Control.Exception (SomeException, displayException, try) +import Poppy.Internal.Db (DbPool, closePool, connect) +import Support.TestMigrations (runTestMigrations) +import System.Environment (lookupEnv) +import Test.Hspec (Spec, SpecWith, afterAll, beforeAll) + +newtype TestEnv = TestEnv + { envPool :: DbPool + } + +withTestDb :: SpecWith TestEnv -> Spec +withTestDb spec = + beforeAll setupTestEnv $ + afterAll destroyTestEnv 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 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/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);