diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,39 @@ +# Changelog + +## 0.5.0.0 + +Add `Hasql.Check.Inferred.TH`: quoters for statements without annotations, +whose parameter and result types come from the Haskell types they are used +at. Each type names its Postgres type at the type level, so a `newtype` +deriving `Value`, or deriving it via `Domain`, is checked as such, and +`Vector`s and lists are arrays, and an enumeration deriving it via `PgEnum` +is an enum, whose labels the checker compares with the database's. Add +`--inferred`, which checks them, and the `hasql-check-ghc` package, which +gets their types from GHC: `Hasql.Check.Plugin`, a GHC plugin that checks +them while they compile, and `hasql-check-hie`, which reads them from GHC's +`.hie` files. + +## 0.4.0.0 + +Add `--types`, and `HASQL_CHECK_TYPES` for compile-time checks: warn about +annotations that convert a table column, or a parameter assigned to one, to a +narrower type. + +Suppress warnings with `hasql-check: allow` directives above a quote, or with +a baseline file (`--baseline`, `--write-baseline`, `HASQL_CHECK_BASELINE`). +Add `--fail-on-warnings`, and `--files0-from` for checking every file in one +run. + +## 0.3.0.0 + +Add `Hasql.Check.TH`: hasql-th's quasiquoters, checking their statements +against a database while they compile. + +## 0.2.0.0 + +Add `--nullability`: warn about result columns annotated non-null that can be +null. + +## 0.1.0.0 + +Initial release. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,28 @@ +BSD 3-Clause License + +Copyright (c) 2021-2026, Kronor + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +2. 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. + +3. Neither the name of the copyright holder nor the names of its + 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 HOLDER 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,639 @@ +# hasql-check + +Check the SQL in your [hasql-th](https://hackage.haskell.org/package/hasql-th) +quasiquotes against a real PostgreSQL database, before it reaches production. + +hasql-th checks that a statement parses. `hasql-check` asks Postgres whether it +runs against your schema, and whether the types you annotated it with hold: + +``` +$ hasql-check src/Shop/Customers.hs +Error in src/Shop/Customers.hs:12:5 +ERROR: column "emial" does not exist +LINE 1: SELECT emial :: text FROM customer WHERE id = $1 :: int8 + ^ +HINT: Perhaps you meant to reference the column "customer.email". +``` + +It runs as a command for CI, and as a drop-in replacement for `Hasql.TH` +that reports the same errors while GHC compiles. It also comes with quoters +that need no annotations at all, taking the types from how the statement is +used in Haskell. + +## Contents + +- [Installing](#installing) +- [The example schema](#the-example-schema) +- [Statements that do not match the schema](#statements-that-do-not-match-the-schema) +- [Columns that can be null](#columns-that-can-be-null---nullability) +- [Annotations that narrow a value](#annotations-that-narrow-a-value---types) +- [Allowing a warning on purpose](#allowing-a-warning-on-purpose) +- [Adopting it in an existing codebase](#adopting-it-in-an-existing-codebase) +- [Running it in CI](#running-it-in-ci) +- [Checking while you compile](#checking-while-you-compile) +- [Statements without annotations](#statements-without-annotations) +- [Reference](#reference) +- [Limitations](#limitations) + +## Installing + +``` +git clone https://github.com/kronor-io/hasql-check +cd hasql-check +cabal install exe:hasql-check +``` + +It links against libpq, so install your platform's PostgreSQL client library +first (`libpq-dev` on Debian and Ubuntu). + +## The example schema + +The examples below run against this schema: + +```sql +create table customer ( + id int8 primary key, + email text not null, + nickname text +); + +create table orders ( + id int8 primary key, + customer_id int8 not null references customer, + total_cents int8 not null, + quantity int2 not null +); +``` + +Point `hasql-check` at the database with `--database`, or set +`DATABASE_URL`: + +``` +export DATABASE_URL=postgres://localhost/shop +``` + +## Statements that do not match the schema + +`hasql-check` finds every hasql-th quote in the files you give it and +`PREPARE`s its statement. Given this module: + +```haskell +customerEmail :: Statement Int64 (Maybe Text) +customerEmail = + [maybeStatement| + select emial :: text + from customer + where id = $1 :: int8 + |] +``` + +``` +$ hasql-check src/Shop/Customers.hs +Error in src/Shop/Customers.hs:12:5 +ERROR: column "emial" does not exist +LINE 1: SELECT emial :: text FROM customer WHERE id = $1 :: int8 + ^ +HINT: Perhaps you meant to reference the column "customer.email". +``` + +It exits 1 when any statement fails. A dropped column, a renamed function or a +changed type in a migration shows up here, for every statement that uses it. + +To see which quotes it would check, without connecting: + +``` +$ hasql-check --list src/Shop/*.hs +src/Shop/Customers.hs:12:5: maybeStatement +src/Shop/Orders.hs:11:5: maybeStatement +src/Shop/Orders.hs:19:5: resultlessStatement +src/Shop/Profiles.hs:12:5: maybeStatement +src/Shop/Profiles.hs:20:5: vectorStatement +``` + +## Columns that can be null: `--nullability` + +hasql-th decodes `nickname :: text` as a `Text`. If the column holds a `NULL`, +decoding fails at runtime, and only for that row. `--nullability` asks the +database: + +```haskell +profile :: Statement Int64 (Maybe (Text, Text)) +profile = + [maybeStatement| + select email :: text, nickname :: text + from customer + where id = $1 :: int8 + |] + +customerTotals :: Statement () (Vector (Text, Int64)) +customerTotals = + [vectorStatement| + select c.email :: text, o.total_cents :: int8 + from customer c + left join orders o on o.customer_id = c.id + |] +``` + +``` +$ hasql-check --nullability src/Shop/Profiles.hs +Warning in src/Shop/Profiles.hs:12:5 + column 2 (nickname) is annotated non-null, but public.customer.nickname is nullable +Warning in src/Shop/Profiles.hs:20:5 + column 2 (total_cents) is annotated non-null, but comes from the nullable side of an outer join +``` + +`total_cents` is `NOT NULL` in its table, but a customer without orders gets a +`NULL` from the left join. Any of these fixes the warning: + +```haskell +select email :: text, nickname :: text? -- decode it as Maybe Text +... +where id = $1 :: int8 and nickname is not null -- or only return rows that have one +``` + +or, if every row really has one, a `NOT NULL` constraint on the column. + +Expressions (`count(*)`, `coalesce(...)`) and views are not checked, since +Postgres does not say whether they can be null. + +## Annotations that narrow a value: `--types` + +An annotation is a cast, and `PREPARE` accepts a cast that loses information. +`--types` warns about them: + +```haskell +orderTotal :: Statement Int64 (Maybe Int32) +orderTotal = + [maybeStatement| + select total_cents :: int4 + from orders + where id = $1 :: int8 + |] + +placeOrder :: Statement (Int64, Int64, Int64, Int32) () +placeOrder = + [resultlessStatement| + insert into orders (id, customer_id, total_cents, quantity) + values ($1 :: int8, $2 :: int8, $3 :: int8, $4 :: int4) + |] +``` + +``` +$ hasql-check --types src/Shop/Orders.hs +Warning in src/Shop/Orders.hs:11:5 + column 1 (total_cents) is annotated integer, but is a bigint: it may overflow +Warning in src/Shop/Orders.hs:19:5 + parameter $4 is annotated integer, but is assigned to a smallint column: it may overflow +``` + +Both work until a value does not fit. It warns about lossy integer and +floating-point conversions, `numeric` to integers or floats, and +`timestamptz` to `timestamp` or `date`. It checks result columns that read a +table column, and parameters assigned in `INSERT ... VALUES` and +`UPDATE ... SET`. It does not check expressions (`count(*) :: int4` is almost +always deliberate), or parameters that are only compared (`where id = $1 :: +int4` widens the column, it does not narrow the parameter). + +## Allowing a warning on purpose + +When a warning is wrong for your data, say so in a comment directly above the +quote, naming the rule and the column (or `$n` for a parameter): + +```haskell +profile = + -- Every customer picks a nickname at sign-up; the column is nullable + -- only for accounts migrated from the old shop. + -- hasql-check: allow nullable(nickname) + [maybeStatement| + select email :: text, nickname :: text + ... + +customerTotals = + -- hasql-check: allow nullable(total) + [vectorStatement| + select c.email :: text, o.total_cents :: int8 + ... +``` + +The first directive silences the `nickname` warning. The second names a column +the statement does not have, so it allows nothing, and that is reported too, +which keeps typos and stale directives from piling up: + +``` +$ hasql-check --nullability src/Shop/Profiles.hs +Warning in src/Shop/Profiles.hs:24:5 + column 2 (total_cents) is annotated non-null, but comes from the nullable side of an outer join + allow nullable(total) suppresses nothing +``` + +The rules are `nullable` and `narrowing`. Several go on one line, +`-- hasql-check: allow nullable(street, city), narrowing($4)`. Quote column +names that have spaces: `nullable("display name")`. (A directive cannot go +inside the SQL, because hasql-th does not accept SQL comments in a quote.) + +## Adopting it in an existing codebase + +An existing codebase will have warnings. To fail CI on new ones without +fixing the old ones first, record them in a baseline. (These examples assume +the `emial` typo above is fixed; a statement that does not prepare is always +an error, baseline or not.) + +``` +$ hasql-check --nullability --types --write-baseline .hasql-check-baseline src/Shop/*.hs +$ cat .hasql-check-baseline +# hasql-check baseline: findings to ignore. Written by --write-baseline. +09d21523a3c4b3f0 narrowing total_cents # src/Shop/Orders.hs:11:5 +07d99122eb9eeadd narrowing $4 # src/Shop/Orders.hs:19:5 +f44d2176be2dd654 nullable nickname # src/Shop/Profiles.hs:12:5 +9bdbaed7ce894852 nullable total_cents # src/Shop/Profiles.hs:20:5 +``` + +Commit it, and check against it with `--fail-on-warnings`. The existing +findings pass: + +``` +$ hasql-check --nullability --types --baseline .hasql-check-baseline --fail-on-warnings src/Shop/*.hs +$ echo $? +0 +``` + +A new one fails: + +```haskell +customerNickname :: Statement Int64 (Vector Text) +customerNickname = + [vectorStatement| + select c.nickname :: text + from orders o join customer c on c.id = o.customer_id + where o.id = $1 :: int8 + |] +``` + +``` +$ hasql-check --nullability --types --baseline .hasql-check-baseline --fail-on-warnings src/Shop/*.hs +Warning in src/Shop/Orders.hs:26:5 + column 1 (nickname) is annotated non-null, but public.customer.nickname is nullable +$ echo $? +1 +``` + +An entry is keyed by a hash of the statement, not by its line, so moving a +quote or reformatting it keeps the entry, and changing its SQL drops it. +Rewrite the baseline with `--write-baseline` as you fix findings. + +## Running it in CI + +Run your migrations against a fresh database, then check every module. Give +it the file list with `--files0-from` rather than `xargs`, which can split the +files across several runs: + +```yaml +jobs: + hasql-check: + runs-on: ubuntu-latest + services: + postgres: + image: postgres:18 + env: + POSTGRES_PASSWORD: postgres + ports: ["5432:5432"] + env: + DATABASE_URL: postgres://postgres:postgres@localhost:5432/postgres + steps: + - uses: actions/checkout@v4 + - run: ./migrate.sh # however you apply your schema + - run: cabal install exe:hasql-check # from a checkout of this repository + - run: | + find src -name '*.hs' -print0 \ + | hasql-check --nullability --types \ + --baseline .hasql-check-baseline --fail-on-warnings --files0-from - +``` + +If your statements read session settings with `current_setting(...)`, give +them placeholder values (`PGOPTIONS="-c app.tenant_id=0"`). Postgres +evaluates those calls while planning, and the nullability check plans every +statement. + +## Checking while you compile + +`Hasql.Check.TH` exports hasql-th's quasiquoters, and checks each statement +against a database as GHC compiles it. Swap the import: + +```haskell +import Hasql.Check.TH -- instead of: import Hasql.TH +``` + +and set `HASQL_CHECK_DATABASE_URL`. The error then appears at the quote, in +GHC's output and in your editor: + +``` +$ HASQL_CHECK_DATABASE_URL=postgres://localhost/shop cabal build +src/Shop/Customers.hs:12:21: error: [GHC-39584] + • hasql-check: the statement does not prepare against HASQL_CHECK_DATABASE_URL: +ERROR: column "emial" does not exist +LINE 1: SELECT emial :: text FROM customer WHERE id = $1 :: int8 + ^ +HINT: Perhaps you meant to reference the column "customer.email". + + • In the quasi-quotation: + [maybeStatement| + select emial :: text + from customer + where id = $1 :: int8 + |] +``` + +Without the variable nothing is checked, so CI and release builds behave +exactly as with `Hasql.TH`. If the database cannot be reached, the build +prints one warning and carries on. Each check takes about a millisecond, over +one connection shared by every quote. + +GHC only runs a quote when it recompiles the module, so a migration does not +recheck modules that have not changed. Set `HASQL_CHECK_SCHEMA_FILE` to a file +that changes with your schema, such as a migration plan, and every module +with a checked quote depends on it. GHCi and ghciwatch notice the change on +their own; for `cabal build`, also list the file in the package's +`extra-source-files`. Keep running the command in CI, which checks everything +regardless. + +## Statements without annotations + +`Hasql.Check.Inferred.TH` has quoters that take no annotations. The Haskell +type a statement is used at decides its parameter and result types: + +```haskell +import Hasql.Check.Inferred.TH + +profile :: Statement Int64 (Maybe (Text, Maybe Text)) +profile = [maybeStatement| select email, nickname from customer where id = $1 |] +``` + +The quoter annotates the parameters, and casts the result columns to the +types they are read as, in a projection around the statement: + +```sql +WITH hasql_check_result (c1, c2) AS (SELECT email, nickname FROM customer WHERE id = $1 :: int8) +SELECT c1 :: text, c2 :: text FROM hasql_check_result +``` + +So a `varchar` column can be read as `Text` and an `int4` one as `Int64`, and +without them hasql's decoders need the exact type, and fail at runtime. The +statement itself is left as written, so its `DISTINCT ON`, `ORDER BY` and +`GROUP BY` mean what they did, and a `*` is cast too. A `WITH` list of its own +goes first, where a data-modifying statement in it must be. + +The type does not have to be on the binding. GHC infers it from how the rows +are used, as it does for any other value: + +```haskell +cancelPayment :: Int64 -> Text -> Session () + +cancelAll :: Int64 -> Session () +cancelAll merchantId = do + payments <- Session.statement merchantId [vectorStatement| select id, reference from payment where merchant_id = $1 |] + for_ payments \(paymentId, reference) -> cancelPayment paymentId reference +``` + +Here the statement is a `Statement Int64 (Vector (Int64, Text))`, without +saying so anywhere. + +Each Haskell type stands for one Postgres type: + +| Haskell | Postgres | +|---|---| +| `Bool` | `bool` | +| `Int16`, `Int32`, `Int64` | `int2`, `int4`, `int8` | +| `Float`, `Double` | `float4`, `float8` | +| `Scientific` | `numeric` | +| `Text` | `text` | +| `ByteString` | `bytea` | +| `UUID` | `uuid` | +| `Day`, `TimeOfDay` | `date`, `time` | +| `LocalTime`, `UTCTime` | `timestamp`, `timestamptz` | +| `Aeson.Value` | `jsonb` | +| `Maybe a` | `a`, and may be NULL | +| `Vector a`, `[a]` | `a[]`; `Vector (Maybe a)` for elements that may be NULL | + +Parameters and rows are a single value or a tuple of up to eight, and `()` +for no parameters. + +### Your own types + +A `newtype` is sent and read as the type it wraps: + +```haskell +{-# LANGUAGE UndecidableInstances #-} + +newtype Email = Email Text + deriving newtype (Value) +``` + +For a column of a domain, derive through `Domain` and its name. The statement +then casts to the domain, so Postgres checks its constraints on what you send: + +```haskell +newtype Quantity = Quantity Int16 + deriving (Value) via Domain "quantity" Int16 +``` + +Each type's Postgres type is part of its `Value` instance, as the associated +type `PgType`, so a type of your own needs nothing else to be checked. +Deriving the instance needs `UndecidableInstances` in that module. + +An enumeration is sent and read as a Postgres enum, each constructor as the +label of the same name: + +```haskell +-- create type payment_state as enum ('PENDING', 'PAID', 'REFUNDED'); + +data PaymentState = PENDING | PAID + deriving stock (Generic) + deriving (Value) via PgEnum "payment_state" PaymentState +``` + +The labels are part of the type too, so the checker compares them with the +enum's, for the way each statement uses it: a label the Haskell type cannot +read fails when the statement reads it, and one the database does not have +fails when it is sent. + +``` +Error in src/Shop/Enums.hs:20:11 +column 1 (state) is read as Shop.Enums.PaymentState, which cannot read labels payment_state has: REFUNDED +``` + +### Checking them while you compile + +The types are only known once GHC has type-checked the module, after the +quoter ran. A GHC plugin, `Hasql.Check.Plugin` from the `hasql-check-ghc` +package, checks each statement then, as `Hasql.Check.TH` does for hasql-th's +quoters. Add it to the package: + +``` +build-depends: hasql-check-ghc +ghc-options: -fplugin=Hasql.Check.Plugin +``` + +and set `HASQL_CHECK_DATABASE_URL`, and the same environment variables as +for [`Hasql.Check.TH`](#environment-variables-for-hasqlcheckth-and-the-plugin). A statement +that does not fit the schema is a compile error at its quote, in GHC's output +and in your editor: + +``` +src/Shop/Newtypes.hs:35:34: error: + hasql-check: the statement does not fit HASQL_CHECK_DATABASE_URL's schema: + column 1 (nickname) is text, but is read as Shop.Newtypes.Nickname (bigint), which Postgres converts it to only when told to, and can fail to at runtime + | +35 | nicknameOf = [singletonStatement| select nickname from customer where id = $1 |] + | ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +``` + +Without the variable it checks nothing, and if the database cannot be reached +it says so once and lets the build carry on. + +### Checking them in CI + +In CI, as for annotated statements, check everything with the command +instead. Have GHC write `.hie` files, and read the types from them with +`hasql-check-hie`, also from `hasql-check-ghc`: + +``` +$ cabal build --ghc-options='-fwrite-ide-info -hiedir=.hie' +$ hasql-check-hie $(find .hie -name '*.hie') > statements.jsonl +$ hasql-check --inferred statements.jsonl --nullability --types +``` + +Given this module: + +```haskell +profile :: Statement Int64 (Maybe (Text, Maybe Text)) +profile = [maybeStatement| select email, nickname from customer where id = $1 |] + +orderTotal :: Statement Int64 (Maybe Int32) +orderTotal = [maybeStatement| select total_cents from orders where id = $1 |] + +totals :: Statement () (Vector (Text, Int64)) +totals = [vectorStatement| select c.email, o.total_cents from customer c left join orders o on o.customer_id = c.id |] + +setQuantity :: Statement (Int64, Int64) () +setQuantity = [resultlessStatement| update orders set quantity = $1 where id = $2 |] +``` + +it reports, in terms of the Haskell types: + +``` +Warning in src/Shop/Orders.hs:15:14 + column 1 (total_cents) is read as integer, but is a bigint: it may overflow +Warning in src/Shop/Orders.hs:18:10 + column 2 (total_cents) is not a Maybe in Haskell, but comes from the nullable side of an outer join +Warning in src/Shop/Orders.hs:21:15 + parameter $1 is sent as bigint, but is assigned to a smallint column: it may overflow +``` + +Each statement is checked as the annotated hasql-th statement it is sent as, +so everything above applies: errors, directives, baselines and +`--fail-on-warnings`. The statement is prepared as it is sent, with the +parameter types hasql sends. It also fails when the Haskell type reads a +different number of columns than the statement returns, and when it sends a +parameter the statement does not use: the statement runs, but whatever the +parameter was for, a filter say, does not happen. + +A quote that is both in a source file you pass and in `--inferred` is checked +once, as inferred. + +It also fails when a column must be converted in a way that can fail. +Postgres converts a value to almost any type when told to, even `'abc'` to a +number, so the cast must not be the only thing that makes a column fit: + +```haskell +newtype Nickname = Nickname Int64 + deriving newtype (Value) + +nicknameOf :: Statement CustomerId Nickname +nicknameOf = [singletonStatement| select nickname from customer where id = $1 |] +``` + +``` +Error in src/Shop/Newtypes.hs:35:14 +column 1 (nickname) is text, but is read as Shop.Newtypes.Nickname (bigint), which Postgres converts it to only when told to, and can fail to at runtime +``` + +A column whose type Postgres converts on its own, `varchar` to `text` or +`int4` to `int8`, is fine, and one that narrows is a `--types` warning. + +A statement must have concrete types where it is written: a binding of type +`(Params p, Row r) => Statement p r` does not compile, since its Postgres +types cannot be known there. Give it a concrete type. + +`hasql-check-hie` needs no database, so it can run inside a sandboxed build, +such as a Nix derivation, with only the `--inferred` step outside it. + +The plugin and `hasql-check-hie` use GHC's own library, and GHC's +internals change with each release: build `hasql-check-ghc` with the GHC +your project uses. It supports GHC 9.12 and 9.14. + +## Reference + +### Options + +| Option | | +|---|---| +| `-d`, `--database CONNINFO` | libpq connection string or URI. Default: `DATABASE_URL`, then `psql_conn_string`, then libpq's `PG*` variables. | +| `-n`, `--nullability` | Warn about non-null annotations on columns that can be null. | +| `-t`, `--types` | Warn about annotations that narrow a value. | +| `-b`, `--baseline FILE` | Ignore the findings listed in `FILE`. | +| `--write-baseline FILE` | Write the current findings to `FILE`. | +| `--fail-on-warnings` | Exit 1 if anything is warned about. | +| `--files0-from FILE` | Also check the NUL-separated file names in `FILE`, or on stdin with `-`. | +| `--inferred FILE` | Also check the statements of `Hasql.Check.Inferred.TH` in `FILE`, as `hasql-check-hie` writes them, or on stdin with `-`. Repeatable. | +| `-q`, `--quoter NAME` | Also check quotes using this quoter, for your own quoters built on hasql-th. Repeatable. | +| `-l`, `--list` | List the quotes that would be checked, without connecting. | + +It checks `singletonStatement`, `maybeStatement`, `vectorStatement`, +`foldStatement`, `resultlessStatement` and `rowsAffectedStatement`, qualified +or not. It skips quotes inside comments and string literals, and +`uncheckedSql`, which is meant for scripts `PREPARE` cannot take. + +Exit codes: 0 when everything prepares (and, with `--fail-on-warnings`, +nothing is warned about), 1 otherwise, 2 for bad arguments. + +### Environment variables for `Hasql.Check.TH` and the plugin + +| Variable | | +|---|---| +| `HASQL_CHECK_DATABASE_URL` | The database to check against. Unset: nothing is checked. | +| `HASQL_CHECK_NULLABILITY` | Set: also print the `--nullability` warnings. | +| `HASQL_CHECK_TYPES` | Set: also print the `--types` warnings. | +| `HASQL_CHECK_BASELINE` | A baseline file, as written by `--write-baseline`. | +| `HASQL_CHECK_SCHEMA_FILE` | A file that changes with the schema, for recompilation. | + +The warnings go to stderr in GHC's format, rather than through GHC, so +`-Werror` does not turn them into errors. + +## Limitations + +- The nullability and narrowing checks skip statements they cannot take + apart: `UNION`s, and `SELECT *`. +- They need the plan, so a statement that reads a session setting the + connection lacks is only partly checked; see [Running it in CI](#running-it-in-ci). +- The quoters without annotations do not take composite types yet, nor + arrays of more than one dimension. An enum's labels are its constructors' + names; for others, write the `Value` instance, with its `PgLabels`. A `String` is not an array: + use `Text`. A `CALL` cannot be + wrapped, so its result columns must have exactly the types they are read + as. +- The default build parses statements as upstream hasql-th does. Building with + the `kronor-syntax` flag instead accepts the Haskell targets + (`$f (a :: int8)`) and parameter fields (`$1.$field`) of Kronor's hasql-th + fork, and needs Kronor's fork of `postgresql-syntax`. + +## Development + +`cabal test` starts a throwaway PostgreSQL server, so `initdb`, `pg_ctl` and +`psql` must be on `PATH`. The plugin's tests compile fixtures with GHC +itself, which finds the plugin through the package environment cabal writes +(`write-ghc-environment-files: always`, in `cabal.project`). + +The nullability check follows [sqlx](https://github.com/launchbadge/sqlx)'s: +the statement is prepared again without its annotations so that Postgres +reports what each column reads, and its `EXPLAIN` plan shows the outer joins +and `IS NOT NULL` filters. diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,342 @@ +-- | +-- Module : Main +-- Copyright : (c) 2022 Kronor.io +-- +-- License : BSD-3-Clause +-- Maintainer : lorenzo@kronor.io +-- Stability : experimental +-- Portability : GHC +module Main where + +import Control.Applicative ((<|>)) +import Control.Monad (forM, forM_, when) +import Data.ByteString qualified +import Data.Either (isLeft, rights) +import Data.List (isSuffixOf) +import Data.Text (Text) +import Data.Text qualified +import Data.Text.Encoding qualified +import Hasql.Check +import Hasql.Check.Finding +import Hasql.Check.Inferred.Quote (Inferred (..), annotated, checkInferred, readInferred) +import Hasql.Check.Lexer +import Hasql.Check.Nullability qualified as Nullability +import Hasql.Check.Parser +import Hasql.Check.Quoter +import Hasql.Check.Types qualified as Types +import Hasql.Connection qualified +import Hasql.Connection.Settings qualified +import Hasql.Session qualified +import Pqi qualified +import Pqi.Ffi qualified +import System.Console.GetOpt +import System.Directory (doesFileExist) +import System.Environment (getArgs, getProgName) +import System.Environment qualified +import System.Exit (ExitCode (ExitFailure), exitSuccess, exitWith) +import System.FilePath (splitDirectories) +import System.IO (hPutStr, hPutStrLn, stderr) +import Prelude hiding (lex) + + +data Options = Options + { database :: Maybe Text + , extraQuoters :: [Text] + , listOnly :: Bool + , nullability :: Bool + , types :: Bool + , baselineFile :: Maybe FilePath + , writeBaseline :: Maybe FilePath + , failOnWarnings :: Bool + , filesFrom :: Maybe FilePath + , inferred :: [FilePath] + , showHelp :: Bool + } + + +defaultOptions :: Options +defaultOptions = + Options + { database = Nothing + , extraQuoters = [] + , listOnly = False + , nullability = False + , types = False + , baselineFile = Nothing + , writeBaseline = Nothing + , failOnWarnings = False + , filesFrom = Nothing + , inferred = [] + , showHelp = False + } + + +options :: [OptDescr (Options -> Options)] +options = + [ Option + ['d'] + ["database"] + (ReqArg (\s o -> o{database = Just (Data.Text.pack s)}) "CONNINFO") + "libpq connection string or URI to prepare against" + , Option + ['q'] + ["quoter"] + (ReqArg (\s o -> o{extraQuoters = Data.Text.pack s : o.extraQuoters}) "NAME") + "also check quasiquotes with this quoter name (repeatable)" + , Option + ['l'] + ["list"] + (NoArg (\o -> o{listOnly = True})) + "list the quasiquotes that would be checked, without connecting" + , Option + ['n'] + ["nullability"] + (NoArg (\o -> o{nullability = True})) + "warn about result columns annotated non-null that can be null" + , Option + ['t'] + ["types"] + (NoArg (\o -> o{types = True})) + "warn about annotations that convert a value to a narrower type" + , Option + ['b'] + ["baseline"] + (ReqArg (\s o -> o{baselineFile = Just s}) "FILE") + "ignore the findings listed in FILE" + , Option + [] + ["write-baseline"] + (ReqArg (\s o -> o{writeBaseline = Just s}) "FILE") + "write the findings, after directives, to FILE as a baseline" + , Option + [] + ["fail-on-warnings"] + (NoArg (\o -> o{failOnWarnings = True})) + "exit 1 if anything is warned about" + , Option + [] + ["files0-from"] + (ReqArg (\s o -> o{filesFrom = Just s}) "FILE") + "also check the NUL-separated file names in FILE, or stdin if FILE is -" + , Option + [] + ["inferred"] + (ReqArg (\s o -> o{inferred = s : o.inferred}) "FILE") + "also check the quotes of Hasql.Check.Inferred.TH in FILE, as hasql-check-hie writes them, or stdin if FILE is - (repeatable)" + , Option + ['h'] + ["help"] + (NoArg (\o -> o{showHelp = True})) + "show this help" + ] + + +usage :: IO String +usage = do + progName <- getProgName + let header = + unlines + [ "Usage: " ++ progName ++ " [options...] FILES..." + , "" + , "Prepares the SQL in every hasql-th quasiquote in FILES against a live database," + , "so statements that do not match the schema fail here instead of at runtime." + , "" + , "The database is the first of: --database, $DATABASE_URL, $psql_conn_string, and" + , "otherwise libpq's own defaults (PGHOST, PGPORT, PGDATABASE, PGUSER, ...)." + , "" + , "Quoters checked by default: " ++ Data.Text.unpack (Data.Text.intercalate ", " quotersSupported) + ] + pure (usageInfo header options) + + +execOpts :: IO (Options, [FilePath]) +execOpts = do + argv <- getArgs + case getOpt Permute options argv of + (fs, files, []) -> do + let opts = foldl (flip ($)) defaultOptions fs + when opts.showHelp do + usage >>= putStr + exitSuccess + -- One invocation for every file, rather than xargs splitting them + -- between several, so that --write-baseline sees all the findings. + listed <- case opts.filesFrom of + Nothing -> pure [] + Just path -> do + contents <- if path == "-" then Data.ByteString.getContents else Data.ByteString.readFile path + pure + [ Data.Text.unpack (Data.Text.Encoding.decodeUtf8Lenient name) + | name <- Data.ByteString.split 0 contents + , not (Data.ByteString.null name) + ] + let allFiles = files <> listed + when (null allFiles && null opts.filesFrom && null opts.inferred) do + usage >>= hPutStr stderr + exitWith (ExitFailure 2) + pure (opts, allFiles) + (_, _, errs) -> do + usage >>= hPutStr stderr . (concat errs ++) + exitWith (ExitFailure 2) + + +-- | The connection string. An empty one leaves every setting to libpq's +-- environment variables and defaults. +connectionString :: Options -> IO Text +connectionString opts = case opts.database of + Just conn -> pure conn + Nothing -> do + databaseUrl <- nonEmpty <$> System.Environment.lookupEnv "DATABASE_URL" + legacy <- nonEmpty <$> System.Environment.lookupEnv "psql_conn_string" + pure (maybe "" Data.Text.pack (databaseUrl <|> legacy)) + where + nonEmpty = \case + Just "" -> Nothing + other -> other + + +getConnection :: Options -> IO Hasql.Connection.Connection +getConnection opts = do + sqlConnString <- connectionString opts + eConn <- Hasql.Connection.acquire Pqi.Ffi.adapter (Hasql.Connection.Settings.connectionString sqlConnString) + case eConn of + Left err -> do + error (show err) + Right conn -> pure conn + + +-- | hasql 2 has no @withLibPQConnection@; the supported escape hatch is a +-- session built with 'Hasql.Session.onLibpqConnection', which hands over the +-- raw pqi connection and takes it back unchanged. +withLibPqConnection :: Hasql.Connection.Connection -> (Pqi.Connection -> IO a) -> IO a +withLibPqConnection conn action = do + result <- + Hasql.Connection.use + conn + (Hasql.Session.onLibpqConnection (\pq -> (\r -> (Right r, pq)) <$> action pq)) + case result of + Left err -> error (show err) + Right a -> pure a + + +data PrepareError + = ParseError FilePath String + | DbError QuasiQuote String + deriving stock (Eq, Show) + + +-- | The checked quasiquotes in each file, or why the file could not be read. +collect :: [Text] -> [FilePath] -> IO [(FilePath, Either String [(QuasiQuote, Maybe Inferred)])] +collect quoters files = + forM files \file -> do + errParse <- parseFile file + pure (file, map (,Nothing) . filter (\(QuasiQuote (_, quoter) _) -> isQuoterIn quoters quoter) <$> errParse) + + +-- | The inferred quotes in each file, each standing for the hasql-th quote +-- its Haskell types annotate it as. +collectInferred :: [FilePath] -> IO [(FilePath, Either String [(QuasiQuote, Maybe Inferred)])] +collectInferred paths = + concat <$> forM paths \path -> do + contents <- if path == "-" then Data.ByteString.getContents else Data.ByteString.readFile path + case readInferred contents of + Left err -> pure [(path, Left err)] + Right quotes -> + pure + [ case annotated q of + Left err -> (q.file, Left (q.file <> ":" <> show q.line <> ":" <> show q.column <> ": " <> err)) + Right sql -> (q.file, Right [(QuasiQuote (here, q.quoter) (here, sql), Just q)]) + | q <- quotes + , let here = AlexPn 0 q.line q.column + ] + + +-- | Whether a quote found in a source file is one --inferred has: its +-- quoter has the same names as hasql-th's. The paths may be relative to +-- different directories, so one need only end with the other; and the quote +-- must be the same, so that one in another package with the same path is +-- still checked. +isInferred :: [(FilePath, Either String [(QuasiQuote, Maybe Inferred)])] -> (FilePath, QuasiQuote) -> Bool +isInferred inferredQuotes (file, QuasiQuote (AlexPn _ line column, _) (_, sql)) = + or + [ q.line == line && q.column == column && q.sql == sql && sameFile q.file + | (_, Right quotes) <- inferredQuotes + , (_, Just q) <- quotes + ] + where + sameFile other = components other `isSuffixOf` components file || components file `isSuffixOf` components other + components = filter (`notElem` ["", "."]) . splitDirectories + + +location :: FilePath -> QuasiQuote -> String +location file (QuasiQuote (AlexPn _ quoterRow quoterCol, _) _) = + file <> ":" <> show quoterRow <> ":" <> show quoterCol + + +main :: IO () +main = do + (opts, fileList) <- execOpts + fromSources <- collect (opts.extraQuoters <> quotersSupported) fileList + inferredQuotes <- collectInferred (reverse opts.inferred) + let parsed = [(file, filter (\(qq, _) -> not (isInferred inferredQuotes (file, qq))) <$> quotes) | (file, quotes) <- fromSources] <> inferredQuotes + if opts.listOnly + then do + forM_ parsed \case + (file, Left err) -> putStrLn ("Error in " <> file <> "\n" <> err) + (file, Right qqs) -> forM_ qqs \(qq@(QuasiQuote (_, quoter) _), _) -> + putStrLn (location file qq <> ": " <> Data.Text.unpack quoter) + when (any (isLeft . snd) parsed) (exitWith (ExitFailure 1)) + else do + baseline <- forM opts.baselineFile \path -> do + contents <- Data.Text.Encoding.decodeUtf8Lenient <$> Data.ByteString.readFile path + either (\err -> hPutStrLn stderr err >> exitWith (ExitFailure 2)) pure (readBaseline contents) + conn <- getConnection opts + results <- withLibPqConnection conn \libPqConn -> do + catalogue <- + if opts.nullability || opts.types + then either (error . ("Cannot read the catalogue: " <>)) Just <$> Nullability.prepareSession libPqConn + else pure Nothing + fmap concat . forM parsed $ \case + (file, Left err) -> do + putStrLn ("Error in " <> file) + putStrLn err + pure [Left (ParseError file err)] + (file, Right qqs) -> do + -- An inferred quote's file may not be where it was + -- compiled from; it then has no directives. + exists <- doesFileExist file + fileLines <- if exists then Data.Text.lines . Data.Text.Encoding.decodeUtf8Lenient <$> Data.ByteString.readFile file else pure [] + forM qqs \(qq@(QuasiQuote (AlexPn _ line _, quoter) (_, stmt)), inferredQuote) -> do + let checkedRules = + [Nullable | opts.nullability && isQuoterIn Nullability.resultQuoters quoter] + <> [Narrowing | opts.types] + report h found = do + let (kept, messages) = settle checkedRules (directivesAbove fileLines line) baseline h found + when (not (null messages)) do + putStrLn ("Warning in " <> location file qq) + forM_ messages \m -> putStrLn (" " <> m) + pure (Right (length messages, [BaselineEntry h f.rule f.subject (Data.Text.pack (location file qq)) | f <- kept])) + failed err = do + putStrLn ("Error in " <> location file qq) + putStrLn err + pure (Left (DbError qq err)) + case inferredQuote of + -- Checked as it is sent; its warnings in terms of + -- its Haskell types. + Just q -> + checkInferred libPqConn catalogue (Nullable `elem` checkedRules) (Narrowing `elem` checkedRules) q >>= \case + Left err -> failed err + Right (found, h) -> report h found + Nothing -> + Hasql.Check.prepare libPqConn "" stmt >>= \case + Left err -> failed err + Right _ -> case (catalogue, parseStmt stmt) of + (Just cat, Right ast) -> do + nullable <- if Nullable `elem` checkedRules then Nullability.check libPqConn cat ast else pure [] + narrowing <- if opts.types then Types.check libPqConn cat ast else pure [] + report (statementHash (renderStmt ast)) (nullable <> narrowing) + _ -> pure (Right (0, [])) + let (warningCounts, entries) = unzip (rights results) + forM_ opts.writeBaseline \path -> + Data.ByteString.writeFile path (Data.Text.Encoding.encodeUtf8 (renderBaseline (concat entries))) + when (any isLeft results) (exitWith (ExitFailure 1)) + when (opts.failOnWarnings && sum warningCounts > 0) (exitWith (ExitFailure 1)) diff --git a/hasql-check.cabal b/hasql-check.cabal new file mode 100644 --- /dev/null +++ b/hasql-check.cabal @@ -0,0 +1,257 @@ +cabal-version: 3.0 +name: hasql-check +version: 0.5.0.0 +synopsis: Check hasql-th statements against a live PostgreSQL schema +description: + Finds the hasql-th quasiquotes in Haskell source files and PREPAREs each + statement against a live PostgreSQL database, so statements that no longer + match the schema fail in CI rather than at runtime. + +category: Database, Development +homepage: https://github.com/kronor-io/hasql-check +bug-reports: https://github.com/kronor-io/hasql-check/issues +license: BSD-3-Clause +license-file: LICENSE +author: Pranay Sashank, Jose Lorenzo Rodriguez +maintainer: lorenzo@kronor.io, pranay.sashank@kronor.io +copyright: 2021-2026 Kronor +build-type: Simple +tested-with: GHC ==9.10.3 || ==9.12.4 || ==9.14.1 +extra-doc-files: + ChangeLog.md + README.md + +source-repository head + type: git + location: https://github.com/kronor-io/hasql-check + +flag lint + description: lint + manual: True + default: False + +flag kronor-syntax + description: + Accept the hasql-th extensions of Kronor's forks (Haskell targets and + Haskell param fields). Needs Kronor's fork of postgresql-syntax. + + manual: True + default: False + +library + exposed-modules: + Hasql.Check + Hasql.Check.Annotate + Hasql.Check.Compile + Hasql.Check.Finding + Hasql.Check.Inferred + Hasql.Check.Inferred.Quote + Hasql.Check.Inferred.TH + Hasql.Check.Lexer + Hasql.Check.Nullability + Hasql.Check.Parser + Hasql.Check.Quoter + Hasql.Check.TH + Hasql.Check.Types + + hs-source-dirs: src + default-language: GHC2021 + default-extensions: + ApplicativeDo + BangPatterns + BinaryLiterals + BlockArguments + ConstraintKinds + DataKinds + DefaultSignatures + DeriveAnyClass + DeriveDataTypeable + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveTraversable + DerivingStrategies + DerivingVia + DoAndIfThenElse + DuplicateRecordFields + EmptyDataDecls + EmptyDataDeriving + ExistentialQuantification + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + ImportQualifiedPost + InstanceSigs + KindSignatures + LambdaCase + MultiParamTypeClasses + MultiWayIf + NamedFieldPuns + NoImplicitPrelude + OverloadedRecordDot + OverloadedStrings + PartialTypeSignatures + PatternGuards + PatternSynonyms + PolyKinds + QuasiQuotes + RankNTypes + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + StrictData + TupleSections + TypeApplications + TypeFamilies + TypeSynonymInstances + ViewPatterns + + ghc-options: + -Wall -Wcompat -Widentities -Wincomplete-record-updates + -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints + -freverse-errors -fhide-source-paths + + if flag(lint) + ghc-options: -Werror + + build-depends: + , aeson >=2.0 && <2.4 + , array >=0.5 && <0.6 + , base >=4.20 && <4.23 + , bytestring >=0.11 && <0.13 + , containers >=0.6 && <0.9 + , directory >=1.3 && <1.4 + , hasql >=2.0 && <2.1 + , hasql-th >=0.5 && <0.6 + , mtl >=2.2 && <2.4 + , postgresql-syntax >=0.5 && <0.6 + , pqi >=1.1 && <1.2 + , pqi-ffi >=1.0 && <1.1 + , scientific >=0.3 && <0.4 + , template-haskell >=2.18 && <2.25 + , text >=2.0 && <2.2 + , time >=1.11 && <1.17 + , uuid >=1.3 && <1.4 + , vector >=0.12 && <0.14 + + if flag(kronor-syntax) + cpp-options: -DKRONOR_SYNTAX + + build-tool-depends: + , alex:alex >=3.2 && <4 + , happy:happy >=1.20 && <3 + +executable hasql-check + main-is: Main.hs + hs-source-dirs: app + default-language: GHC2021 + default-extensions: + ApplicativeDo + BangPatterns + BinaryLiterals + BlockArguments + ConstraintKinds + DataKinds + DefaultSignatures + DeriveAnyClass + DeriveDataTypeable + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveTraversable + DerivingStrategies + DerivingVia + DoAndIfThenElse + DuplicateRecordFields + EmptyDataDecls + EmptyDataDeriving + ExistentialQuantification + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + ImportQualifiedPost + InstanceSigs + KindSignatures + LambdaCase + MultiParamTypeClasses + MultiWayIf + NamedFieldPuns + NoImplicitPrelude + OverloadedRecordDot + OverloadedStrings + PartialTypeSignatures + PatternGuards + PatternSynonyms + PolyKinds + QuasiQuotes + RankNTypes + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + StrictData + TupleSections + TypeApplications + TypeFamilies + TypeSynonymInstances + ViewPatterns + + ghc-options: + -Wall -Wcompat -Widentities -Wincomplete-record-updates + -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints + -freverse-errors -fhide-source-paths + + build-depends: + , base >=4.20 && <4.23 + , bytestring >=0.11 && <0.13 + , directory >=1.3 && <1.4 + , filepath >=1.4 && <1.6 + , hasql >=2.0 && <2.1 + , hasql-check + , pqi >=1.1 && <1.2 + , pqi-ffi >=1.0 && <1.1 + , text >=2.0 && <2.2 + + if flag(lint) + ghc-options: -Werror + +-- The executable tests start their own PostgreSQL server, so initdb, pg_ctl +-- and psql must be on PATH. +test-suite hasql-check-test + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: test + default-language: GHC2021 + default-extensions: + BlockArguments + DataKinds + LambdaCase + OverloadedStrings + + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + + if flag(lint) + ghc-options: -Werror + + build-depends: + , base >=4.20 && <4.23 + , bytestring >=0.11 && <0.13 + , directory >=1.3 && <1.4 + , filepath >=1.4 && <1.6 + , hasql >=2.0 && <2.1 + , hasql-check + , pqi-ffi >=1.0 && <1.1 + , process >=1.6 && <1.7 + , sydtest >=0.19 && <0.34 + , template-haskell >=2.18 && <2.25 + , temporary >=1.3 && <1.4 + , text >=2.0 && <2.2 + , vector >=0.12 && <0.14 + + build-tool-depends: hasql-check:hasql-check + + if flag(kronor-syntax) + cpp-options: -DKRONOR_SYNTAX diff --git a/src/Hasql/Check.hs b/src/Hasql/Check.hs new file mode 100644 --- /dev/null +++ b/src/Hasql/Check.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE CPP #-} + +-- | +-- Module : Hasql.Check +-- Copyright : (c) 2022 Kronor.io +-- +-- License : BSD-3-Clause +-- Maintainer : lorenzo@kronor.io +-- Stability : experimental +-- Portability : GHC +module Hasql.Check where + +import Data.ByteString (ByteString) +import Data.Text (Text) +import Data.Text qualified as Text +import Data.Text.Encoding qualified as Text +import PostgresqlSyntax qualified as Ast +import Pqi qualified +import Prelude + + +-- | Turn the SQL text inside a quasiquote into the SQL the splice actually +-- sends to Postgres, mirroring @Hasql.TH.expPreparableStmtAstParser@ composed +-- with @Hasql.TH.Extraction.Exp.sql@ line for line. Rendering at 'mempty' +-- drops the nullability markers. +renderSql :: Text -> Either String ByteString +renderSql sql = renderStmt <$> parseStmt sql + + +-- | The statement in a quasiquote, as the splice would render it. +parseStmt :: Text -> Either String Ast.PreparableStmt +parseStmt sql = either (Left . Text.unpack) (Right . lowerAst) (Ast.parse quoterSettings sql) + + +-- | A statement in plain SQL, as Postgres reads it, whatever syntax this +-- build takes in hasql-th's quotes: for the quoters of +-- "Hasql.Check.Inferred.TH", and the annotated statements that stand for +-- theirs, which hasql-th's nullability markers may annotate. +-- +-- Not lowered: Kronor's fork numbers the placeholders afresh as it lowers +-- its parameter fields, which would turn a lone @$2@ into @$1@. +parsePlainStmt :: Bool -> Text -> Either String Ast.PreparableStmt +parsePlainStmt markers sql = either (Left . Text.unpack) Right (Ast.parse (Ast.nullabilityMarkers markers) sql) + + +renderStmt :: Ast.PreparableStmt -> ByteString +renderStmt = Text.encodeUtf8 . Ast.toText mempty + +#ifdef KRONOR_SYNTAX + +-- | The settings Kronor's fork of hasql-th parses with: upstream's nullability +-- markers, plus its Haskell targets and Haskell param fields. +quoterSettings :: Ast.Settings +quoterSettings = + mconcat + [ Ast.nullabilityMarkers True + , Ast.haskellTargets True + , Ast.haskellParamFields True + ] + + +-- | 'Ast.lower' numbers the placeholders as they fall in the tree that will +-- actually be rendered - the one with the Haskell targets erased - but hands +-- back the tree that still carries them, because the quasiquoter builds its +-- row decoder by walking those targets. We have no decoder to build, so the +-- erasure the quasiquoter defers to 'Hasql.TH.Extraction.Exp' happens right +-- here. +lowerAst :: Ast.PreparableStmt -> Ast.PreparableStmt +lowerAst ast = Ast.eraseHaskellTargets (fst (Ast.lower ast)) + +#else + +-- | The settings upstream hasql-th parses with. +quoterSettings :: Ast.Settings +quoterSettings = Ast.nullabilityMarkers True + + +-- | Upstream hasql-th renders the statement as parsed. +lowerAst :: Ast.PreparableStmt -> Ast.PreparableStmt +lowerAst = id + +#endif + + +prepare :: Pqi.Connection -> Text -> Text -> IO (Either String ()) +prepare conn stmtName unParsedStmt = + either (pure . Left) (prepareStmt conn (Text.encodeUtf8 stmtName)) (parseStmt unParsedStmt) + + +-- | Prepare a statement under a name, returning the server's error if it fails. +prepareStmt :: Pqi.Connection -> ByteString -> Ast.PreparableStmt -> IO (Either String ()) +prepareStmt conn stmtName stmt = do + mr <- conn.prepare stmtName (renderStmt stmt) Nothing + case mr of + Nothing -> Left . maybe "Something went wrong" (Text.unpack . Text.decodeUtf8Lenient) <$> conn.errorMessage + Just r -> do + rs <- r.resultStatus + if rs `elem` [Pqi.EmptyQuery, Pqi.BadResponse, Pqi.NonfatalError, Pqi.FatalError] + then maybe (Left "Something went wrong") (Left . Text.unpack . Text.decodeUtf8Lenient) <$> r.resultErrorMessage + else pure (Right ()) diff --git a/src/Hasql/Check/Annotate.hs b/src/Hasql/Check/Annotate.hs new file mode 100644 --- /dev/null +++ b/src/Hasql/Check/Annotate.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE CPP #-} + +-- | +-- Module : Hasql.Check.Annotate +-- Copyright : (c) 2026 Kronor.io +-- +-- License : BSD-3-Clause +-- Maintainer : lorenzo@kronor.io +-- Stability : experimental +-- Portability : GHC +-- +-- Annotate the parameters of a statement that has no annotations, as +-- hasql-th asks for. +-- +-- 'Hasql.Check.Inferred.TH' annotates with the types of the Haskell values a +-- statement is used with, and the checker annotates the same way, so that it +-- checks the statement the quoter sends. Result columns are not annotated +-- here: the quoter casts them around the statement, where they cannot change +-- what it means. +module Hasql.Check.Annotate ( + annotate, + typename, + placeholder, + untypedLiterals, +) where + +import Data.Data (Data, cast, gmapT) +import Data.Foldable (toList) +import Data.Text (Text) +import Data.Text qualified as Text +import PostgresqlSyntax qualified as Ast +import Prelude + + +-- | A type, as an annotation would name it - @int8@, @public.payment_state@, +-- @text[]@ - nullable or not. An array's nullability is its elements'. +typename :: Text -> Bool -> Either String Ast.Typename +typename name nullable = case Ast.parse mempty name of + Right (Ast.Typename setof t _ Nothing) -> Right (Ast.Typename setof t nullable Nothing) + Right (Ast.Typename setof t _ (Just (dimensions, _))) -> Right (Ast.Typename setof t False (Just (dimensions, nullable))) + Left _ -> Left ("not a Postgres type name: " <> Text.unpack name) + + +-- | A made-up type with a plain name, to find in the rendered statement. +placeholder :: Text -> Ast.Typename +placeholder name = + Ast.Typename False (Ast.GenericTypeSimpleTypename (Ast.GenericType (Ast.UnquotedIdent name) Nothing Nothing)) False Nothing + + +-- | The statement with each occurrence of the @n@th parameter, counting from +-- 1, cast to the type given for it, if one is. A parameter that is +-- subscripted or has a field taken, @$1['key']@, is cast before that: +-- @($1 :: jsonb)['key']@. +annotate :: (Int -> Maybe Ast.Typename) -> Ast.PreparableStmt -> Ast.PreparableStmt +annotate param = go + where + go :: Data b => b -> b + go x = case cast x of + Just (Ast.CExprAExpr p@(Ast.ParamCExpr n Nothing)) | Just t <- param n, Just r <- cast (Ast.TypecastAExpr (Ast.CExprAExpr p) t) -> r + _ -> case cast x of + Just (Ast.CExprBExpr p@(Ast.ParamCExpr n Nothing)) | Just t <- param n, Just r <- cast (Ast.TypecastBExpr (Ast.CExprBExpr p) t) -> r + _ -> case cast x of + Just (Ast.ParamCExpr n (Just indirection)) + | Just t <- param n + , Just r <- cast (Ast.InParensCExpr (Ast.TypecastAExpr (Ast.CExprAExpr (Ast.ParamCExpr n Nothing)) t) (Just indirection)) -> + r + _ -> gmapT go x + + +-- | The result columns, counting from 1, that are a string literal or NULL +-- with no type of its own, and the literal: Postgres reads one as the type +-- it is cast to, so whether the quoter's cast works depends only on the +-- literal. Only a plain SELECT's columns are found. +untypedLiterals :: Ast.PreparableStmt -> [(Int, Text)] +untypedLiterals = \case + Ast.SelectPreparableStmt (Ast.NoParensSelectStmt (Ast.SelectNoParens _ (Ast.SimpleSelectSelectClause (Ast.NormalSimpleSelect (Just t) _ _ _ _ _ _)) _ _ _)) -> + [(n, Ast.toText mempty e) | (n, Just e) <- zip [1 ..] (targeting t), untyped e] + _ -> [] + where + targeting = \case + Ast.NormalTargeting l -> normalTargets l + Ast.AllTargeting (Just l) -> targets l + Ast.DistinctTargeting _ l -> targets l + Ast.AllTargeting Nothing -> [] + untyped = \case + Ast.CExprAExpr (Ast.AexprConstCExpr (Ast.SAexprConst _)) -> True + Ast.CExprAExpr (Ast.AexprConstCExpr Ast.NullAexprConst) -> True + _ -> False + + +-- | Each target's expression; nothing for a @*@, which stops the counting. +targets :: Ast.TargetList -> [Maybe Ast.AExpr] +targets (Ast.TargetList els) = takeWhile (/= Nothing) (map expr (toList els)) + where + expr = \case + Ast.AliasedExprTargetEl a _ -> Just a + Ast.ImplicitlyAliasedExprTargetEl a _ -> Just a + Ast.ExprTargetEl a -> Just a + Ast.AsteriskTargetEl -> Nothing + +#ifdef KRONOR_SYNTAX + +normalTargets :: Ast.HsTargetList -> [Maybe Ast.AExpr] +normalTargets (Ast.HsTargetList els) = takeWhile (/= Nothing) (map one (toList els)) + where + one = \case + Ast.SqlTargetEl te -> case te of + Ast.AliasedExprTargetEl a _ -> Just a + Ast.ImplicitlyAliasedExprTargetEl a _ -> Just a + Ast.ExprTargetEl a -> Just a + Ast.AsteriskTargetEl -> Nothing + _ -> Nothing + +#else + +normalTargets :: Ast.TargetList -> [Maybe Ast.AExpr] +normalTargets = targets + +#endif diff --git a/src/Hasql/Check/Compile.hs b/src/Hasql/Check/Compile.hs new file mode 100644 --- /dev/null +++ b/src/Hasql/Check/Compile.hs @@ -0,0 +1,204 @@ +-- | +-- Module : Hasql.Check.Compile +-- Copyright : (c) 2026 Kronor.io +-- +-- License : BSD-3-Clause +-- Maintainer : lorenzo@kronor.io +-- Stability : experimental +-- Portability : GHC +-- +-- Checking statements while GHC compiles them, from "Hasql.Check.TH"'s +-- quoters or from a compiler plugin: the configuration, read from the +-- environment, one connection for the whole compilation, and warnings that +-- GHC's output and an editor pick up. +-- +-- * @HASQL_CHECK_DATABASE_URL@: a libpq connection string or URI. Unset, +-- nothing is checked. +-- * @HASQL_CHECK_SCHEMA_FILE@: a file that changes whenever the schema does, +-- such as a migration plan. +-- * @HASQL_CHECK_NULLABILITY@, @HASQL_CHECK_TYPES@: when set, the warnings of +-- @hasql-check --nullability@ and @--types@ too. +-- * @HASQL_CHECK_BASELINE@: a baseline file, as @--write-baseline@ writes it. +module Hasql.Check.Compile ( + -- * Configuration + Config (..), + readConfig, + + -- * The connection + Session (..), + withSession, + reportUnavailable, + + -- * Warnings + warnings, + warning, +) where + +import Control.Concurrent.MVar (MVar, modifyMVar, newMVar) +import Control.Exception (SomeException, try) +import Control.Monad (unless) +import Data.ByteString qualified as ByteString +import Data.ByteString.Char8 qualified as ByteString.Char8 +import Data.Either (fromRight) +import Data.IORef (IORef, atomicModifyIORef', newIORef) +import Data.Maybe (isJust) +import Data.Text (Text) +import Data.Text qualified as Text +import Data.Text.Encoding qualified as Text +import Hasql.Check.Finding (Baseline, Finding, Rule, directivesAbove, readBaseline, settle) +import Hasql.Check.Nullability qualified as Nullability +import Pqi qualified +import Pqi.Ffi qualified +import System.Environment (lookupEnv) +import System.IO (hPutStrLn, stderr) +import System.IO.Unsafe (unsafePerformIO) +import Prelude + + +-- * Configuration + + +data Config = Config + { databaseUrl :: Maybe String + , schemaFile :: Maybe FilePath + , nullability :: Bool + , types :: Bool + , baseline :: Maybe FilePath + } + + +readConfig :: IO Config +readConfig = + Config + <$> nonEmpty "HASQL_CHECK_DATABASE_URL" + <*> nonEmpty "HASQL_CHECK_SCHEMA_FILE" + <*> (isJust <$> nonEmpty "HASQL_CHECK_NULLABILITY") + <*> (isJust <$> nonEmpty "HASQL_CHECK_TYPES") + <*> nonEmpty "HASQL_CHECK_BASELINE" + where + nonEmpty name = + lookupEnv name >>= \case + Just "" -> pure Nothing + other -> pure other + + +-- * The connection + + +data Session = Session + { url :: String + -- ^ What the connection was made to. A long GHCi session can outlive a + -- change of HASQL_CHECK_DATABASE_URL, and must follow it. + , connection :: Pqi.Connection + , catalogue :: Maybe (ByteString.ByteString, Nullability.Catalogue) + -- ^ Loaded for nullability and types, keyed by the schema file's contents. + } + + +-- | One connection for every statement the compiler checks, created on first +-- use. The lock also keeps the statements of one check together, which +-- nullability needs: it prepares, explains and deallocates a named +-- statement. + +{- HLINT ignore session "Avoid restricted function" -} +-- A process-wide variable is the point: it outlives every splice. +session :: MVar (Maybe Session) +session = unsafePerformIO (newMVar Nothing) +{-# NOINLINE session #-} + + +-- | Run a check on the connection to the given database, with the catalogue +-- if asked for; or why the database cannot be reached. A connection that +-- breaks during a check - a restarted database under a long GHCi session - +-- is replaced, and the check run once more on the new one. +withSession :: Config -> String -> Bool -> (Session -> IO a) -> IO (Either String a) +withSession config url withCatalogue action = modifyMVar session \current -> do + fingerprint <- + if withCatalogue + then maybe (pure ByteString.empty) readFileOrEmpty config.schemaFile + else pure ByteString.empty + let attempt existing = + open fingerprint existing >>= \case + Left why -> pure (Nothing, Left why) + Right s -> do + result <- action s + status <- s.connection.status + pure (if status == Pqi.ConnectionOk then Just s else Nothing, Right result) + attempt current >>= \case + (Nothing, Right _) | Just _ <- current -> attempt Nothing + result -> pure result + where + open fingerprint = \case + Just s + | s.url /= url -> do + s.connection.finish + open fingerprint Nothing + | not withCatalogue || fmap fst s.catalogue == Just fingerprint -> pure (Right s) + | otherwise -> loadCatalogue fingerprint s.connection + Nothing -> do + conn <- Pqi.Ffi.adapter.connectdb (ByteString.Char8.pack url) + status <- conn.status + if status /= Pqi.ConnectionOk + then Left . maybe "cannot connect" ByteString.Char8.unpack <$> conn.errorMessage + else + if withCatalogue + then loadCatalogue fingerprint conn + else pure (Right (Session url conn Nothing)) + + loadCatalogue fingerprint conn = + Nullability.prepareSession conn >>= \case + Left err -> pure (Left err) + Right cat -> pure (Right (Session url conn (Just (fingerprint, cat)))) + + readFileOrEmpty path = fromRight ByteString.empty <$> (try (ByteString.readFile path) :: IO (Either SomeException ByteString.ByteString)) + + +-- | Whether the database being unavailable has already been reported. + +{- HLINT ignore reportedUnavailable "Avoid restricted function" -} +reportedUnavailable :: IORef Bool +reportedUnavailable = unsafePerformIO (newIORef False) +{-# NOINLINE reportedUnavailable #-} + + +-- | Say, once a compilation, that the database cannot be reached: not about +-- any one statement, so with no location. +reportUnavailable :: String -> IO () +reportUnavailable why = do + reported <- atomicModifyIORef' reportedUnavailable (True,) + unless reported (hPutStrLn stderr ("hasql-check: not checking statements: " <> why)) + + +-- * Warnings + + +-- | The warnings to report for a statement at a line of a file, after its +-- directives and the baseline, if any. +warnings :: Config -> [Rule] -> FilePath -> Int -> Text -> [Finding] -> IO [String] +warnings config rules file line fingerprint found + | null rules = pure [] + | otherwise = do + fileLines <- readLines file + known <- traverse readBaselineFile config.baseline + let (_, messages) = settle rules (directivesAbove fileLines line) (either (const Nothing) Just =<< known) fingerprint found + pure (maybe [] (\err -> ["cannot read HASQL_CHECK_BASELINE: " <> err]) (known >>= either Just (const Nothing)) <> messages) + + +-- | A warning in GHC's format, so that tools reading GHC's output pick it up, +-- but written to stderr rather than reported to GHC: under -Werror GHC would +-- fail the build on it, and these are advice. +warning :: FilePath -> (Int, Int) -> String -> IO () +warning file (line, column) message = + hPutStrLn stderr (file <> ":" <> show line <> ":" <> show column <> ": warning: hasql-check: " <> message) + + +-- | A file's lines, or none if it cannot be read. +readLines :: FilePath -> IO [Text] +readLines path = either (const []) (Text.lines . Text.decodeUtf8Lenient) <$> (try (ByteString.readFile path) :: IO (Either SomeException ByteString.ByteString)) + + +readBaselineFile :: FilePath -> IO (Either String Baseline) +readBaselineFile path = + (try (ByteString.readFile path) :: IO (Either SomeException ByteString.ByteString)) >>= \case + Left e -> pure (Left (show e)) + Right bytes -> pure (readBaseline (Text.decodeUtf8Lenient bytes)) diff --git a/src/Hasql/Check/Finding.hs b/src/Hasql/Check/Finding.hs new file mode 100644 --- /dev/null +++ b/src/Hasql/Check/Finding.hs @@ -0,0 +1,252 @@ +-- | +-- Module : Hasql.Check.Finding +-- Copyright : (c) 2026 Kronor.io +-- +-- License : BSD-3-Clause +-- Maintainer : lorenzo@kronor.io +-- Stability : experimental +-- Portability : GHC +-- +-- Warnings about a statement, and the two ways of suppressing them. +-- +-- A directive, in the comment lines directly above the line a quote starts on, +-- suppresses findings about that quote's statement: +-- +-- > -- hasql-check: allow nullable(street, city), narrowing($4) +-- > [singletonStatement| ... |] +-- +-- A baseline file lists findings to ignore wherever their statement is, so +-- that existing findings can be left while new ones fail CI. +module Hasql.Check.Finding ( + -- * Findings + Rule (..), + ruleName, + Finding (..), + + -- * Directives + Allowance, + directivesAbove, + applyDirectives, + + -- * Baselines + Baseline, + BaselineEntry (..), + statementHash, + readBaseline, + renderBaseline, + inBaseline, + + -- * Both + settle, +) where + +import Data.Bits (xor) +import Data.ByteString (ByteString) +import Data.ByteString qualified as ByteString +import Data.Char (isSpace) +import Data.List (partition, sortOn) +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Text (Text) +import Data.Text qualified as Text +import Data.Word (Word64) +import Numeric (showHex) +import Prelude + + +-- * Findings + + +data Rule + = -- | A result column annotated non-null that can be null. + Nullable + | -- | An annotation that converts a value to a narrower type. + Narrowing + deriving stock (Eq, Ord, Show, Enum, Bounded) + + +ruleName :: Rule -> Text +ruleName = \case + Nullable -> "nullable" + Narrowing -> "narrowing" + + +data Finding = Finding + { rule :: Rule + , subject :: Text + -- ^ The result column's name, or the parameter as @$n@. + , message :: String + } + + +-- * Directives + + +-- | A rule allowed for a subject. +type Allowance = (Rule, Text) + + +-- | The allowances in the block of comment lines directly above a line, given +-- the file's lines and the line, from 1. Malformed directives are reported. +directivesAbove :: [Text] -> Int -> ([Allowance], [String]) +directivesAbove fileLines line = + foldMap parseLine (takeWhile isComment (reverse (take (line - 1) fileLines))) + where + isComment = Text.isPrefixOf "--" . Text.stripStart + parseLine l = case Text.breakOn "hasql-check:" l of + (_, rest) | not (Text.null rest) -> parseDirective (Text.strip (Text.drop (Text.length "hasql-check:") rest)) + _ -> mempty + + +parseDirective :: Text -> ([Allowance], [String]) +parseDirective t = case Text.stripPrefix "allow" t of + Just rest -> foldMap entry (splitTopLevel (Text.strip rest)) + Nothing -> ([], ["directive not understood: " <> Text.unpack t]) + where + entry e = case Text.breakOn "(" (Text.strip e) of + (name, args) + | Just inner <- Text.stripPrefix "(" args >>= Text.stripSuffix ")" + , Just r <- lookup (Text.strip name) [(ruleName r', r') | r' <- [minBound .. maxBound]] -> + case subjects inner of + Right names -> ([(r, subj) | subj <- names], []) + Left err -> ([], ["directive not understood: " <> Text.unpack e <> ": " <> err]) + _ -> ([], ["directive not understood: " <> Text.unpack e]) + -- Split on the commas between entries, not those inside them. + splitTopLevel = go 0 "" + where + go :: Int -> Text -> Text -> [Text] + go depth acc s = case Text.uncons s of + Nothing -> [acc | not (Text.all isSpace acc)] + Just (c, cs) + | c == ',' && depth == 0 -> acc : go depth "" cs + | c == '(' -> go (depth + 1) (Text.snoc acc c) cs + | c == ')' -> go (depth - 1) (Text.snoc acc c) cs + | otherwise -> go depth (Text.snoc acc c) cs + + +-- | The findings the allowances leave, and the allowances that suppressed +-- nothing for the rules that were checked. +applyDirectives :: [Rule] -> [Allowance] -> [Finding] -> ([Finding], [Allowance]) +applyDirectives checked allowances findings = + (kept, [a | a@(r, _) <- allowances, r `elem` checked, a `Set.notMember` used]) + where + allowed f = (f.rule, f.subject) `elem` allowances + (suppressed, kept) = partition allowed findings + used = Set.fromList [(f.rule, f.subject) | f <- suppressed] + + +-- * Baselines + + +data BaselineEntry = BaselineEntry + { hash :: Text + , entryRule :: Rule + , entrySubject :: Text + , origin :: Text + -- ^ Where the statement was when the entry was written, for people. + } + + +-- | Findings to ignore, by statement, rule and subject. +newtype Baseline = Baseline (Set (Text, Rule, Text)) + + +-- | A stable hash of a statement as rendered, so that layout changes to the +-- quote leave it alone. 64-bit FNV-1a. +statementHash :: ByteString -> Text +statementHash = Text.pack . pad . flip showHex "" . ByteString.foldl' step offset + where + offset = 0xcbf29ce484222325 :: Word64 + step h b = (h `xor` fromIntegral b) * 0x100000001b3 + pad s = replicate (16 - length s) '0' <> s + + +-- | One entry a line: hash, rule, subject, then optionally @# origin@. +readBaseline :: Text -> Either String Baseline +readBaseline = fmap (Baseline . Set.fromList) . traverse entry . filter (not . blank) . Text.lines + where + blank l = Text.null (Text.strip l) || "#" `Text.isPrefixOf` Text.stripStart l + entry l = either (\err -> Left (concat ["Malformed baseline line: ", Text.unpack l, ": ", err])) Right do + let (h, afterHash) = Text.break isSpace (Text.stripStart l) + (r, afterRule) = Text.break isSpace (Text.stripStart afterHash) + r' <- maybe (Left "unknown rule") Right (lookup r [(ruleName x, x) | x <- [minBound .. maxBound]]) + (subj, rest) <- word (Text.stripStart afterRule) + if Text.null (Text.strip rest) || "#" `Text.isPrefixOf` Text.stripStart rest + then Right (h, r', subj) + else Left "trailing text" + + +renderBaseline :: [BaselineEntry] -> Text +renderBaseline entries = + Text.unlines + ( "# hasql-check baseline: findings to ignore. Written by --write-baseline." + : [ Text.unwords [e.hash, ruleName e.entryRule, quote e.entrySubject, "#", e.origin] + | e <- sortOn (\e -> (e.origin, e.hash, e.entryRule, e.entrySubject)) entries + ] + ) + + +inBaseline :: Baseline -> Text -> Finding -> Bool +inBaseline (Baseline entries) h f = (h, f.rule, f.subject) `Set.member` entries + + +-- * Both + + +-- | Apply a quote's directives and the baseline to its statement's findings: +-- the findings left after the directives, which are what a baseline written +-- now would hold, and the messages to report - the findings the baseline does +-- not cover either, malformed directives, and allowances that suppress +-- nothing. +settle :: [Rule] -> ([Allowance], [String]) -> Maybe Baseline -> Text -> [Finding] -> ([Finding], [String]) +settle checked (allowances, malformed) baseline h findings = + ( kept + , [f.message | f <- kept, maybe True (\b -> not (inBaseline b h f)) baseline] + <> malformed + <> [ concat ["allow ", Text.unpack (ruleName r), "(", Text.unpack subj, ") suppresses nothing"] + | (r, subj) <- unused + ] + ) + where + (kept, unused) = applyDirectives checked allowances findings + + +-- * Names + + +-- | A column name as written in a baseline or a directive: bare, or in double +-- quotes when it has spaces or punctuation, with @\\@ and @\"@ escapes. +quote :: Text -> Text +quote name + | not (Text.null name) && Text.all plain name = name + | otherwise = Text.concat ["\"", Text.concatMap escape name, "\""] + where + plain c = not (isSpace c) && c `notElem` ("#\"\\,()" :: String) + escape c = if c == '"' || c == '\\' then Text.pack ['\\', c] else Text.singleton c + + +-- | A name, bare or quoted, at the start of the text, and the text after it. +word :: Text -> Either String (Text, Text) +word t = case Text.uncons t of + Just ('"', rest) -> go "" rest + _ -> + let (bare, rest) = Text.break (\c -> isSpace c || c == ',') t + in if Text.null bare then Left "missing name" else Right (bare, rest) + where + go acc s = case Text.uncons s of + Nothing -> Left "unterminated quote" + Just ('"', rest) -> Right (acc, rest) + Just ('\\', rest) | Just (c, rest') <- Text.uncons rest -> go (Text.snoc acc c) rest' + Just (c, rest) -> go (Text.snoc acc c) rest + + +-- | Comma-separated names, bare or quoted. +subjects :: Text -> Either String [Text] +subjects t + | Text.null (Text.strip t) = Right [] + | otherwise = do + (name, rest) <- word (Text.stripStart t) + case Text.uncons (Text.stripStart rest) of + Nothing -> Right [name] + Just (',', more) -> (name :) <$> subjects more + Just _ -> Left "expected a comma" diff --git a/src/Hasql/Check/Inferred.hs b/src/Hasql/Check/Inferred.hs new file mode 100644 --- /dev/null +++ b/src/Hasql/Check/Inferred.hs @@ -0,0 +1,643 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE UndecidableInstances #-} +-- 'statement' and 'resultless' name their Postgres types through equalities +-- they do not need themselves: with them, GHC works the names out where a +-- statement is used, which is what puts them in the .hie files. +{-# OPTIONS_GHC -Wno-redundant-constraints #-} + +-- | +-- Module : Hasql.Check.Inferred +-- Copyright : (c) 2026 Kronor.io +-- +-- License : BSD-3-Clause +-- Maintainer : lorenzo@kronor.io +-- Stability : experimental +-- Portability : GHC +-- +-- Statements whose encoders and decoders are chosen by the Haskell types they +-- are used with, for the quoters in "Hasql.Check.Inferred.TH". +-- +-- Each Haskell type stands for one Postgres type, named at the type level by +-- 'PgType', and the statement sends the annotations hasql-th would ask for: +-- @select email from customer@ used as a @Statement Int64 Text@ is sent as +-- @select (email)::text from customer@. A @varchar@ column is then read as +-- 'Text', and an @int4@ one as 'Int64', where an exact decoder would fail. +-- +-- Because the names are types, GHC works them out where a statement is used, +-- and records them in its @.hie@ files, where @hasql-check-hie@ reads them: +-- a @newtype@ deriving 'Value' is checked as the type it wraps, with no list +-- of types to keep in step. +module Hasql.Check.Inferred ( + -- * Types + Value (..), + typeName, + Domain (..), + PgEnum (..), + GEnum (..), + qualifiedName, + Column (..), + Params (..), + Row (..), + + -- * Postgres types at the type level + PgColumnType, + PgColumnLabels, + PgParamLabels, + PgColumnLabelLists, + PostgresParamLabels, + PostgresColumnLabels, + PgParamTypes, + PgColumnTypes, + KnownSymbols (..), + PostgresParams, + PostgresColumns, + + -- * Statements + Template (..), + Wrapped (..), + Piece (..), + statement, + resultless, + render, +) where + +import Data.Aeson qualified as Aeson +import Data.ByteString (ByteString) +import Data.Foldable (toList) +import Data.Functor.Contravariant ((>$<)) +import Data.Int (Int16, Int32, Int64) +import Data.Kind (Type) +import Data.Proxy (Proxy (..)) +import Data.Scientific (Scientific) +import Data.Text (Text) +import Data.Text qualified as Text +import Data.Time (Day, LocalTime, TimeOfDay, UTCTime) +import Data.UUID (UUID) +import Data.Vector (Vector) +import GHC.Generics (C1, D1, Generic (..), M1 (..), Meta (..), U1 (..), (:+:) (..)) +import GHC.TypeLits (AppendSymbol, KnownSymbol, Symbol, symbolVal) +import Hasql.Decoders qualified as D +import Hasql.Encoders qualified as E +import Hasql.Statement (Statement) +import Hasql.Statement qualified as Statement +import Language.Haskell.TH.Syntax (Lift) +import PostgresqlSyntax qualified as Ast +import Prelude + + +-- | A Haskell type, and the Postgres type it is sent and read as. +-- +-- A @newtype@ can derive the instance of the type it wraps: +-- +-- > newtype Email = Email Text +-- > deriving newtype (Value) +class Value a where + -- | The Postgres type's name, as an annotation would give it: @"int8"@, + -- @"public.payment_state"@. + type PgType a :: Symbol + + + -- | The labels of the Postgres enum it is, if it is one, for the checker. + type PgLabels a :: [Symbol] + + + type PgLabels a = '[] + + + encodeValue :: E.Value a + decodeValue :: D.Value a + + +-- | The name of a type's Postgres type. +typeName :: forall a. KnownSymbol (PgType a) => Text +typeName = Text.pack (symbolVal (Proxy @(PgType a))) + + +instance Value Bool where + type PgType Bool = "bool" + encodeValue = E.bool + decodeValue = D.bool + + +instance Value Int16 where + type PgType Int16 = "int2" + encodeValue = E.int2 + decodeValue = D.int2 + + +instance Value Int32 where + type PgType Int32 = "int4" + encodeValue = E.int4 + decodeValue = D.int4 + + +instance Value Int64 where + type PgType Int64 = "int8" + encodeValue = E.int8 + decodeValue = D.int8 + + +instance Value Float where + type PgType Float = "float4" + encodeValue = E.float4 + decodeValue = D.float4 + + +instance Value Double where + type PgType Double = "float8" + encodeValue = E.float8 + decodeValue = D.float8 + + +instance Value Scientific where + type PgType Scientific = "numeric" + encodeValue = E.numeric + decodeValue = D.numeric + + +instance Value Text where + type PgType Text = "text" + encodeValue = E.text + decodeValue = D.text + + +instance Value ByteString where + type PgType ByteString = "bytea" + encodeValue = E.bytea + decodeValue = D.bytea + + +instance Value UUID where + type PgType UUID = "uuid" + encodeValue = E.uuid + decodeValue = D.uuid + + +instance Value Day where + type PgType Day = "date" + encodeValue = E.date + decodeValue = D.date + + +instance Value LocalTime where + type PgType LocalTime = "timestamp" + encodeValue = E.timestamp + decodeValue = D.timestamp + + +instance Value UTCTime where + type PgType UTCTime = "timestamptz" + encodeValue = E.timestamptz + decodeValue = D.timestamptz + + +instance Value TimeOfDay where + type PgType TimeOfDay = "time" + encodeValue = E.time + decodeValue = D.time + + +instance Value Aeson.Value where + type PgType Aeson.Value = "jsonb" + encodeValue = E.jsonb + decodeValue = D.jsonb + + +-- | A type sent and read as the one it wraps, under the name of a Postgres +-- domain over it, so that Postgres checks the domain's constraints: +-- +-- > newtype Cents = Cents Int64 +-- > deriving (Value) via Domain "cents" Int64 +newtype Domain (name :: Symbol) a = Domain a + + +instance Value a => Value (Domain name a) where + type PgType (Domain name a) = name + type PgLabels (Domain name a) = PgLabels a + encodeValue = (\(Domain a) -> a) >$< encodeValue + decodeValue = Domain <$> decodeValue + + +-- | A Haskell enumeration sent and read as a Postgres enum, by the enum's +-- name: each constructor, which takes no fields, as the label of the same +-- name. +-- +-- > data PaymentState = PENDING | PAID +-- > deriving stock (Generic) +-- > deriving (Value) via PgEnum "payment_state" PaymentState +-- +-- The checker compares the labels with the enum's in the database. +newtype PgEnum (name :: Symbol) a = PgEnum a + + +instance (KnownSymbol name, Generic a, GEnum (Rep a)) => Value (PgEnum name a) where + type PgType (PgEnum name a) = name + type PgLabels (PgEnum name a) = ConstructorNames (Rep a) + encodeValue = uncurry E.enum (qualifiedName (Text.pack (symbolVal (Proxy @name)))) (\(PgEnum a) -> glabel (from a)) + decodeValue = uncurry D.enum (qualifiedName (Text.pack (symbolVal (Proxy @name)))) (\t -> PgEnum . to <$> lookup t gvalues) + + +-- | A type's schema, if its name has one, and its own name, as the +-- identifiers they are: the name is SQL, as a cast takes it, so a quoted +-- part is taken as it is and an unquoted one in lower case, as Postgres +-- takes them. +qualifiedName :: Text -> (Maybe Text, Text) +qualifiedName n = case Ast.parse mempty n of + Right (Ast.Typename _ (Ast.GenericTypeSimpleTypename (Ast.GenericType i attrs _)) _ _) -> + -- The last part is the type, and the one before it its schema; a + -- part before that is the database, which must be the one connected + -- to. + case reverse (i : maybe [] (\(Ast.Attrs as) -> toList as) attrs) of + own : schema : _ -> (Just (ident schema), ident own) + own : _ -> (Nothing, ident own) + [] -> (Nothing, n) + _ -> (Nothing, n) + where + ident = \case + Ast.QuotedIdent t -> t + Ast.UnquotedIdent t -> t + + +-- | The constructors of an enumeration, by name. +class GEnum f where + gvalues :: [(Text, f p)] + glabel :: f p -> Text + + +instance GEnum f => GEnum (D1 m f) where + gvalues = [(l, M1 x) | (l, x) <- gvalues] + glabel (M1 x) = glabel x + + +instance (GEnum f, GEnum g) => GEnum (f :+: g) where + gvalues = [(l, L1 x) | (l, x) <- gvalues] <> [(l, R1 x) | (l, x) <- gvalues] + glabel = \case + L1 x -> glabel x + R1 x -> glabel x + + +instance KnownSymbol label => GEnum (C1 ('MetaCons label fixity strict) U1) where + gvalues = [(Text.pack (symbolVal (Proxy @label)), M1 U1)] + glabel _ = Text.pack (symbolVal (Proxy @label)) + + +-- | An enumeration's constructor names. +type family ConstructorNames (f :: Type -> Type) :: [Symbol] where + ConstructorNames (D1 m f) = ConstructorNames f + ConstructorNames (f :+: g) = Append (ConstructorNames f) (ConstructorNames g) + ConstructorNames (C1 ('MetaCons label fixity strict) U1) = '[label] + + +type family Append (xs :: [k]) (ys :: [k]) :: [k] where + Append '[] ys = ys + Append (x ': xs) ys = x ': Append xs ys + + +-- | A one-dimensional array, whose elements may be NULL when they are +-- 'Maybe's: a @Vector Int64@ is an @int8[]@. +instance Column a => Value (Vector a) where + type PgType (Vector a) = AppendSymbol (PgColumnType a) "[]" + type PgLabels (Vector a) = PgColumnLabels a + encodeValue = E.foldableArray encodeColumn + decodeValue = D.vectorArray decodeColumn + + +-- | A one-dimensional array, as a list. A 'String' is not one: 'Char' has no +-- Postgres type; use 'Text'. +instance Column a => Value [a] where + type PgType [a] = AppendSymbol (PgColumnType a) "[]" + type PgLabels [a] = PgColumnLabels a + encodeValue = E.foldableArray encodeColumn + decodeValue = D.listArray decodeColumn + + +-- | A column or parameter, which may be NULL when it is a 'Maybe'. +class Column a where + encodeColumn :: E.NullableOrNot E.Value a + decodeColumn :: D.NullableOrNot D.Value a + + +instance {-# OVERLAPPABLE #-} Value a => Column a where + encodeColumn = E.nonNullable encodeValue + decodeColumn = D.nonNullable decodeValue + + +instance Value a => Column (Maybe a) where + encodeColumn = E.nullable encodeValue + decodeColumn = D.nullable decodeValue + + +-- | A column's enum labels, if it is one. +type family PgColumnLabels (a :: Type) :: [Symbol] where + PgColumnLabels (Maybe a) = PgLabels a + PgColumnLabels a = PgLabels a + + +-- | A column's Postgres type. +type family PgColumnType (a :: Type) :: Symbol where + PgColumnType (Maybe a) = PgType a + PgColumnType a = PgType a + + +-- | A statement's parameters: none, one, or a tuple of them. +class Params a where + params :: E.Params a + + +instance Params () where + params = E.noParams + + +instance {-# OVERLAPPABLE #-} Column a => Params a where + params = E.param encodeColumn + + +instance (Column a, Column b) => Params (a, b) where + params = + (fst >$< E.param encodeColumn) + <> (snd >$< E.param encodeColumn) + + +instance (Column a, Column b, Column c) => Params (a, b, c) where + params = + ((\(x, _, _) -> x) >$< E.param encodeColumn) + <> ((\(_, x, _) -> x) >$< E.param encodeColumn) + <> ((\(_, _, x) -> x) >$< E.param encodeColumn) + + +instance (Column a, Column b, Column c, Column d) => Params (a, b, c, d) where + params = + ((\(x, _, _, _) -> x) >$< E.param encodeColumn) + <> ((\(_, x, _, _) -> x) >$< E.param encodeColumn) + <> ((\(_, _, x, _) -> x) >$< E.param encodeColumn) + <> ((\(_, _, _, x) -> x) >$< E.param encodeColumn) + + +instance (Column a, Column b, Column c, Column d, Column e) => Params (a, b, c, d, e) where + params = + ((\(x, _, _, _, _) -> x) >$< E.param encodeColumn) + <> ((\(_, x, _, _, _) -> x) >$< E.param encodeColumn) + <> ((\(_, _, x, _, _) -> x) >$< E.param encodeColumn) + <> ((\(_, _, _, x, _) -> x) >$< E.param encodeColumn) + <> ((\(_, _, _, _, x) -> x) >$< E.param encodeColumn) + + +instance (Column a, Column b, Column c, Column d, Column e, Column f) => Params (a, b, c, d, e, f) where + params = + ((\(x, _, _, _, _, _) -> x) >$< E.param encodeColumn) + <> ((\(_, x, _, _, _, _) -> x) >$< E.param encodeColumn) + <> ((\(_, _, x, _, _, _) -> x) >$< E.param encodeColumn) + <> ((\(_, _, _, x, _, _) -> x) >$< E.param encodeColumn) + <> ((\(_, _, _, _, x, _) -> x) >$< E.param encodeColumn) + <> ((\(_, _, _, _, _, x) -> x) >$< E.param encodeColumn) + + +instance (Column a, Column b, Column c, Column d, Column e, Column f, Column g) => Params (a, b, c, d, e, f, g) where + params = + ((\(x, _, _, _, _, _, _) -> x) >$< E.param encodeColumn) + <> ((\(_, x, _, _, _, _, _) -> x) >$< E.param encodeColumn) + <> ((\(_, _, x, _, _, _, _) -> x) >$< E.param encodeColumn) + <> ((\(_, _, _, x, _, _, _) -> x) >$< E.param encodeColumn) + <> ((\(_, _, _, _, x, _, _) -> x) >$< E.param encodeColumn) + <> ((\(_, _, _, _, _, x, _) -> x) >$< E.param encodeColumn) + <> ((\(_, _, _, _, _, _, x) -> x) >$< E.param encodeColumn) + + +instance (Column a, Column b, Column c, Column d, Column e, Column f, Column g, Column h) => Params (a, b, c, d, e, f, g, h) where + params = + ((\(x, _, _, _, _, _, _, _) -> x) >$< E.param encodeColumn) + <> ((\(_, x, _, _, _, _, _, _) -> x) >$< E.param encodeColumn) + <> ((\(_, _, x, _, _, _, _, _) -> x) >$< E.param encodeColumn) + <> ((\(_, _, _, x, _, _, _, _) -> x) >$< E.param encodeColumn) + <> ((\(_, _, _, _, x, _, _, _) -> x) >$< E.param encodeColumn) + <> ((\(_, _, _, _, _, x, _, _) -> x) >$< E.param encodeColumn) + <> ((\(_, _, _, _, _, _, x, _) -> x) >$< E.param encodeColumn) + <> ((\(_, _, _, _, _, _, _, x) -> x) >$< E.param encodeColumn) + + +-- | The Postgres types of a statement's parameters. +type family PgParamTypes (p :: Type) :: [Symbol] where + PgParamTypes () = '[] + PgParamTypes (a, b) = '[PgColumnType a, PgColumnType b] + PgParamTypes (a, b, c) = '[PgColumnType a, PgColumnType b, PgColumnType c] + PgParamTypes (a, b, c, d) = '[PgColumnType a, PgColumnType b, PgColumnType c, PgColumnType d] + PgParamTypes (a, b, c, d, e) = '[PgColumnType a, PgColumnType b, PgColumnType c, PgColumnType d, PgColumnType e] + PgParamTypes (a, b, c, d, e, f) = '[PgColumnType a, PgColumnType b, PgColumnType c, PgColumnType d, PgColumnType e, PgColumnType f] + PgParamTypes (a, b, c, d, e, f, g) = '[PgColumnType a, PgColumnType b, PgColumnType c, PgColumnType d, PgColumnType e, PgColumnType f, PgColumnType g] + PgParamTypes (a, b, c, d, e, f, g, h) = '[PgColumnType a, PgColumnType b, PgColumnType c, PgColumnType d, PgColumnType e, PgColumnType f, PgColumnType g, PgColumnType h] + PgParamTypes a = '[PgColumnType a] + + +-- | The enum labels of a statement's parameters, one list each. +type family PgParamLabels (p :: Type) :: [[Symbol]] where + PgParamLabels () = '[] + PgParamLabels (a, b) = '[PgColumnLabels a, PgColumnLabels b] + PgParamLabels (a, b, c) = '[PgColumnLabels a, PgColumnLabels b, PgColumnLabels c] + PgParamLabels (a, b, c, d) = '[PgColumnLabels a, PgColumnLabels b, PgColumnLabels c, PgColumnLabels d] + PgParamLabels (a, b, c, d, e) = '[PgColumnLabels a, PgColumnLabels b, PgColumnLabels c, PgColumnLabels d, PgColumnLabels e] + PgParamLabels (a, b, c, d, e, f) = '[PgColumnLabels a, PgColumnLabels b, PgColumnLabels c, PgColumnLabels d, PgColumnLabels e, PgColumnLabels f] + PgParamLabels (a, b, c, d, e, f, g) = '[PgColumnLabels a, PgColumnLabels b, PgColumnLabels c, PgColumnLabels d, PgColumnLabels e, PgColumnLabels f, PgColumnLabels g] + PgParamLabels (a, b, c, d, e, f, g, h) = '[PgColumnLabels a, PgColumnLabels b, PgColumnLabels c, PgColumnLabels d, PgColumnLabels e, PgColumnLabels f, PgColumnLabels g, PgColumnLabels h] + PgParamLabels a = '[PgColumnLabels a] + + +-- | A result row: one column, or a tuple of them. +class Row a where + row :: D.Row a + + +instance {-# OVERLAPPABLE #-} Column a => Row a where + row = D.column decodeColumn + + +instance (Column a, Column b) => Row (a, b) where + row = (,) <$> D.column decodeColumn <*> D.column decodeColumn + + +instance (Column a, Column b, Column c) => Row (a, b, c) where + row = (,,) <$> D.column decodeColumn <*> D.column decodeColumn <*> D.column decodeColumn + + +instance (Column a, Column b, Column c, Column d) => Row (a, b, c, d) where + row = (,,,) <$> D.column decodeColumn <*> D.column decodeColumn <*> D.column decodeColumn <*> D.column decodeColumn + + +instance (Column a, Column b, Column c, Column d, Column e) => Row (a, b, c, d, e) where + row = (,,,,) <$> D.column decodeColumn <*> D.column decodeColumn <*> D.column decodeColumn <*> D.column decodeColumn <*> D.column decodeColumn + + +instance (Column a, Column b, Column c, Column d, Column e, Column f) => Row (a, b, c, d, e, f) where + row = (,,,,,) <$> D.column decodeColumn <*> D.column decodeColumn <*> D.column decodeColumn <*> D.column decodeColumn <*> D.column decodeColumn <*> D.column decodeColumn + + +instance (Column a, Column b, Column c, Column d, Column e, Column f, Column g) => Row (a, b, c, d, e, f, g) where + row = (,,,,,,) <$> D.column decodeColumn <*> D.column decodeColumn <*> D.column decodeColumn <*> D.column decodeColumn <*> D.column decodeColumn <*> D.column decodeColumn <*> D.column decodeColumn + + +instance (Column a, Column b, Column c, Column d, Column e, Column f, Column g, Column h) => Row (a, b, c, d, e, f, g, h) where + row = (,,,,,,,) <$> D.column decodeColumn <*> D.column decodeColumn <*> D.column decodeColumn <*> D.column decodeColumn <*> D.column decodeColumn <*> D.column decodeColumn <*> D.column decodeColumn <*> D.column decodeColumn + + +-- | The Postgres types of a statement's result columns. +type family PgColumnTypes (r :: Type) :: [Symbol] where + PgColumnTypes (a, b) = '[PgColumnType a, PgColumnType b] + PgColumnTypes (a, b, c) = '[PgColumnType a, PgColumnType b, PgColumnType c] + PgColumnTypes (a, b, c, d) = '[PgColumnType a, PgColumnType b, PgColumnType c, PgColumnType d] + PgColumnTypes (a, b, c, d, e) = '[PgColumnType a, PgColumnType b, PgColumnType c, PgColumnType d, PgColumnType e] + PgColumnTypes (a, b, c, d, e, f) = '[PgColumnType a, PgColumnType b, PgColumnType c, PgColumnType d, PgColumnType e, PgColumnType f] + PgColumnTypes (a, b, c, d, e, f, g) = '[PgColumnType a, PgColumnType b, PgColumnType c, PgColumnType d, PgColumnType e, PgColumnType f, PgColumnType g] + PgColumnTypes (a, b, c, d, e, f, g, h) = '[PgColumnType a, PgColumnType b, PgColumnType c, PgColumnType d, PgColumnType e, PgColumnType f, PgColumnType g, PgColumnType h] + PgColumnTypes a = '[PgColumnType a] + + +-- | The enum labels of a statement's result columns, one list each. +type family PgColumnLabelLists (r :: Type) :: [[Symbol]] where + PgColumnLabelLists (a, b) = '[PgColumnLabels a, PgColumnLabels b] + PgColumnLabelLists (a, b, c) = '[PgColumnLabels a, PgColumnLabels b, PgColumnLabels c] + PgColumnLabelLists (a, b, c, d) = '[PgColumnLabels a, PgColumnLabels b, PgColumnLabels c, PgColumnLabels d] + PgColumnLabelLists (a, b, c, d, e) = '[PgColumnLabels a, PgColumnLabels b, PgColumnLabels c, PgColumnLabels d, PgColumnLabels e] + PgColumnLabelLists (a, b, c, d, e, f) = '[PgColumnLabels a, PgColumnLabels b, PgColumnLabels c, PgColumnLabels d, PgColumnLabels e, PgColumnLabels f] + PgColumnLabelLists (a, b, c, d, e, f, g) = '[PgColumnLabels a, PgColumnLabels b, PgColumnLabels c, PgColumnLabels d, PgColumnLabels e, PgColumnLabels f, PgColumnLabels g] + PgColumnLabelLists (a, b, c, d, e, f, g, h) = '[PgColumnLabels a, PgColumnLabels b, PgColumnLabels c, PgColumnLabels d, PgColumnLabels e, PgColumnLabels f, PgColumnLabels g, PgColumnLabels h] + PgColumnLabelLists a = '[PgColumnLabels a] + + +-- | Type-level names, as text. +class KnownSymbols (ss :: [Symbol]) where + symbolTexts :: [Text] + + +instance KnownSymbols '[] where + symbolTexts = [] + + +instance (KnownSymbol s, KnownSymbols ss) => KnownSymbols (s ': ss) where + symbolTexts = Text.pack (symbolVal (Proxy @s)) : symbolTexts @ss + + +-- | The Postgres types of a statement's parameters, as GHC worked them out +-- where it is used. A class of its own, rather than 'KnownSymbols' itself, +-- so that @hasql-check-hie@ finds the whole list in a @.hie@ file, and not +-- only the tails 'KnownSymbols' is built from. +class KnownSymbols ps => PostgresParams ps + + +instance KnownSymbols ps => PostgresParams ps + + +-- | The Postgres types of a statement's result columns; see 'PostgresParams'. +class KnownSymbols cs => PostgresColumns cs + + +instance KnownSymbols cs => PostgresColumns cs + + +-- | The enum labels of a statement's parameters, as GHC worked them out where +-- it is used, for @hasql-check-hie@ to find; see 'PostgresParams'. +class PostgresParamLabels (ls :: [[Symbol]]) + + +instance PostgresParamLabels ls + + +-- | The enum labels of a statement's result columns; see 'PostgresParams'. +class PostgresColumnLabels (ls :: [[Symbol]]) + + +instance PostgresColumnLabels ls + + +-- | A statement's text, as the quoter cut it. +-- +-- Its result columns are cast in a projection around it, +-- +-- > WITH r (c1, c2) AS () SELECT c1 :: int8, c2 :: text FROM r +-- +-- rather than where they are selected, so that the statement means what it +-- did: a cast column is another expression to DISTINCT ON, ORDER BY and +-- GROUP BY, and no longer the primary key other columns depend on. The +-- statement's own WITH list goes first, since one with a data-modifying +-- statement must stay at the top. +data Template = Template + { whole :: [Piece] + -- ^ The statement, for one returning no rows. + , wrapped :: Maybe Wrapped + -- ^ Its parts, unless it cannot be put in a WITH list: a CALL. + } + deriving stock (Eq, Show, Lift) + + +data Wrapped = Wrapped + { with :: Maybe [Piece] + -- ^ Its own WITH list, with the WITH. + , body :: [Piece] + -- ^ The rest of it. + , name :: Text + -- ^ A name for it that it does not use itself. + } + deriving stock (Eq, Show, Lift) + + +-- | Some SQL, or the place of a parameter's annotation. +data Piece + = Sql Text + | -- | The annotation of the nth parameter, counting from 1. + ParamType Int + deriving stock (Eq, Show, Lift) + + +-- | The statement's text, given the Postgres types of its parameters and +-- result columns. +render :: [Text] -> [Text] -> Template -> Text +render paramTypes' columnTypes' t = case (columnTypes', t.wrapped) of + (_ : _, Just w) -> + mconcat + [ maybe "WITH " (\with -> fill with <> ", ") w.with + , w.name + , " (" + , Text.intercalate ", " columns + , ") AS (" + , fill w.body + , ") SELECT " + , Text.intercalate ", " (zipWith (\c ty -> c <> " :: " <> ty) columns columnTypes') + , " FROM " + , w.name + ] + _ -> fill t.whole + where + columns = ["c" <> Text.pack (show i) | i <- [1 .. length columnTypes']] + fill = foldMap \case + Sql sql -> sql + ParamType n -> case drop (n - 1) paramTypes' of + ty : _ | n >= 1 -> " :: " <> ty + _ -> "" + + +-- | A statement returning rows, given what to make of them. +statement :: + forall p r a ps cs pl cl. + ( Params p + , Row r + , ps ~ PgParamTypes p + , cs ~ PgColumnTypes r + , PostgresParams ps + , PostgresColumns cs + , pl ~ PgParamLabels p + , cl ~ PgColumnLabelLists r + , PostgresParamLabels pl + , PostgresColumnLabels cl + ) => + Template -> + (D.Row r -> D.Result a) -> + Statement p a +statement template result = + Statement.preparable (render (symbolTexts @ps) (symbolTexts @cs) template) params (result row) + + +-- | A statement returning no rows. +resultless :: + forall p ps pl. + (Params p, ps ~ PgParamTypes p, PostgresParams ps, pl ~ PgParamLabels p, PostgresParamLabels pl) => + Template -> + Statement p () +resultless template = Statement.preparable (render (symbolTexts @ps) [] template) params D.noResult diff --git a/src/Hasql/Check/Inferred/Quote.hs b/src/Hasql/Check/Inferred/Quote.hs new file mode 100644 --- /dev/null +++ b/src/Hasql/Check/Inferred/Quote.hs @@ -0,0 +1,393 @@ +-- | +-- Module : Hasql.Check.Inferred.Quote +-- Copyright : (c) 2026 Kronor.io +-- +-- License : BSD-3-Clause +-- Maintainer : lorenzo@kronor.io +-- Stability : experimental +-- Portability : GHC +-- +-- Quotes of "Hasql.Check.Inferred.TH", with the Haskell types GHC used them +-- at, as @hasql-check-hie@ writes them: one JSON object a line. +-- +-- Each is checked as the hasql-th quote it stands for - the same SQL, with +-- the annotations the Haskell types give it - so that every check of an +-- annotated quote applies to it too. +module Hasql.Check.Inferred.Quote ( + Inferred (..), + Column (..), + readInferred, + annotated, + sent, + columns, + checkSent, + checkInferred, +) where + +import Data.Aeson ((.!=), (.:), (.:?)) +import Data.Aeson qualified as Aeson +import Data.ByteString (ByteString) +import Data.ByteString.Char8 qualified as ByteString.Char8 +import Data.Functor ((<&>)) +import Data.Text (Text) +import Data.Text qualified as Text +import Data.Text.Encoding qualified as Text +import Data.Word (Word32) +import Hasql.Check (parsePlainStmt, quoterSettings, renderStmt) +import Hasql.Check.Annotate (annotate, typename, untypedLiterals) +import Hasql.Check.Finding (Finding (..), statementHash) +import Hasql.Check.Inferred (Piece (..), Template (..), render) +import Hasql.Check.Inferred.TH (template) +import Hasql.Check.Nullability (Catalogue, query) +import Hasql.Check.Nullability qualified as Nullability +import Hasql.Check.Types qualified as Types +import PostgresqlSyntax qualified as Ast +import Pqi qualified +import Text.Read (readMaybe) +import Prelude + + +data Inferred = Inferred + { file :: FilePath + , line :: Int + , column :: Int + , quoter :: Text + , sql :: Text + , params :: [Column] + , row :: Maybe [Column] + -- ^ Nothing for a statement that returns no rows. + } + + +-- | A parameter or result column: the qualified name of its Haskell type, +-- its Postgres type, and whether it is a 'Maybe'. +data Column = Column + { haskellType :: Text + , postgres :: Text + -- ^ As GHC worked it out from the Haskell type's 'Hasql.Check.Inferred.PgType'. + , labels :: [Text] + -- ^ The labels of the enum it is, if it is one. + , nullable :: Bool + } + + +instance Aeson.FromJSON Inferred where + parseJSON = Aeson.withObject "quote" \o -> + Inferred + <$> o .: "file" + <*> o .: "line" + <*> o .: "column" + <*> o .: "quoter" + <*> o .: "sql" + <*> o .: "params" + <*> o .:? "row" + + +instance Aeson.FromJSON Column where + parseJSON = Aeson.withObject "column" \o -> Column <$> o .: "type" <*> o .: "postgres" <*> (o .:? "labels" .!= []) <*> o .: "nullable" + + +-- | Everything checking an inferred statement finds: why it fails, or the +-- warnings asked for - nullability, narrowing - in terms of its Haskell +-- types, and its fingerprint for baselines: the SQL it sends, so that +-- reading a column as another type is another statement. +checkInferred :: Pqi.Connection -> Maybe Catalogue -> Bool -> Bool -> Inferred -> IO (Either String ([Finding], Text)) +checkInferred conn catalogue nullable narrowing q = + checkSent conn q >>= \case + errors@(_ : _) -> pure (Left (unlines errors)) + [] -> case annotated q >>= parsePlainStmt True of + Left err -> pure (Left err) + Right ast -> do + let readAs = columns q + found <- case catalogue of + Nothing -> pure [] + Just cat -> do + nullables <- if nullable then maybe (pure []) (\cs -> Nullability.checkColumns conn cat (map snd cs) ast) readAs else pure [] + narrowed <- + if narrowing + then (<>) <$> Types.check conn cat ast <*> maybe (pure []) (\cs -> Types.checkColumns conn cat (map fst cs) ast) readAs + else pure [] + pure (nullables <> narrowed) + let fingerprint = either (const (statementHash (renderStmt ast))) (statementHash . Text.encodeUtf8) (sent q) + pure (Right ([f{message = inHaskellTerms f.message} | f <- found], fingerprint)) + + +-- | A finding about an inferred quote, in terms of its Haskell types rather +-- than the annotations they stand for. +inHaskellTerms :: String -> String +inHaskellTerms m = + Text.unpack + . Text.replace "is annotated " (if "parameter " `Text.isPrefixOf` t then "is sent as " else "is read as ") + . Text.replace "is annotated non-null" "is not a Maybe in Haskell" + $ t + where + t = Text.pack m + + +-- | Quotes, one JSON object a line. +readInferred :: ByteString -> Either String [Inferred] +readInferred contents = + traverse + (\(n, l) -> either (\e -> Left ("line " <> show n <> ": " <> e)) Right (Aeson.eitherDecodeStrict l)) + [(n, l) | (n :: Int, l) <- zip [1 ..] (ByteString.Char8.lines contents), not (ByteString.Char8.null l)] + + +-- | The statement with its parameters annotated, as a hasql-th quote: its +-- result columns are cast around it, which the warnings see through +-- 'columns'. +annotated :: Inferred -> Either String Text +annotated q = do + stmt <- parsePlainStmt False q.sql + params <- traverse (\c -> typename c.postgres c.nullable) q.params + let param n = case drop (n - 1) params of + t : _ | n >= 1 -> Just t + _ -> Nothing + pure (Ast.toText quoterSettings (annotate param stmt)) + + +-- | The statement as the quoter sends it, casts and all. +sent :: Inferred -> Either String Text +sent q = do + t <- template q.sql + params <- traverse postgresType q.params + row <- traverse (traverse postgresType) q.row + pure (render (map fst params) (maybe [] (map fst) row) t) + + +-- | The Postgres type each result column is read as, and whether it may be +-- NULL. +columns :: Inferred -> Maybe [(Text, Bool)] +columns q = either (const Nothing) Just . traverse postgresType =<< q.row + + +postgresType :: Column -> Either String (Text, Bool) +postgresType c = Right (c.postgres, c.nullable) + + +-- | Whether the statement, as the quoter sends it, prepares; whether it +-- takes as many parameters as the Haskell type sends, and returns as many +-- columns as it reads, each of a type it can be read as. Prepared, as hasql +-- prepares it, with the parameters' types, which Postgres could not tell for +-- a parameter the statement does not use. +-- +-- A result column is cast to the type it is read as, and Postgres casts +-- anything it can convert, even text to a number, which fails at runtime for +-- text that is not one. So the column must have that type already, or one +-- Postgres converts to it without being told to: implicitly, or on +-- assignment. +checkSent :: Pqi.Connection -> Inferred -> IO [String] +checkSent conn q = case (,,) <$> template q.sql <*> traverse postgresType q.params <*> traverse (traverse postgresType) q.row of + Left err -> pure [err] + Right (t, params, row) -> do + oids <- traverse (oid . fst) params + case sequence oids of + Nothing -> pure ["a parameter's type does not exist: " <> unwords [Text.unpack name | ((name, _), Nothing) <- zip params oids]] + Just paramOids -> do + shape <- described (render (map fst params) [] t) paramOids + case shape of + Left err -> pure [err] + Right found -> do + -- From the statement itself: prepared with the + -- types hasql sends, it takes them all, used or not. + let used = [n | ParamType n <- t.whole] + sends = length q.params + paramErrors = + [ concat ["the Haskell type sends parameter $", show n, ", which the statement does not use"] + | n <- [1 .. sends] + , n `notElem` used + ] + <> [ "the statement uses $" <> show (maximum used) <> ", but the Haskell type sends " <> count "parameter" sends + | not (null used) + , maximum used > sends + ] + columnErrors <- case (row, t.wrapped) of + (Nothing, _) -> pure [] + (Just readAs, _) + | length found /= length readAs -> + pure ["the statement returns " <> count "column" (length found) <> ", but the Haskell type reads " <> show (length readAs)] + (Just readAs, wrapped) -> do + expected <- traverse (oid . fst) readAs + let literals = either (const []) untypedLiterals (parsePlainStmt False q.sql) + missing = [Text.unpack name | ((name, _), Nothing) <- zip readAs expected] + if not (null missing) + then pure ["no such Postgres type: " <> unwords missing] + else + fmap concat . sequence $ + [ case wrapped of + -- A CALL cannot be wrapped, so its + -- columns are not cast: they must + -- already be of the types read, or + -- domains over them. + Nothing -> do + same <- sameBase found' e + if same then pure [] else (\pg -> ["column " <> show i <> " (" <> name <> ") is " <> pg <> ", but is read as " <> Text.unpack c.haskellType]) <$> nameOf found' + Just _ -> case lookup i literals of + Just literal -> literalError i name c literal + Nothing -> conversionError i name c found' e + | (i :: Int, c, (name, found'), Just e) <- zip4 [1 ..] (concat q.row) found expected + , found' /= e + ] + -- What is sent, wrapped in its casts. + sentErrors <- + if null (paramErrors <> columnErrors) + then either pure (const []) <$> described (render (map fst params) (maybe [] (map fst) row) t) paramOids + else pure [] + labelErrors <- + if null (paramErrors <> columnErrors) + then + (<>) + <$> (concat <$> traverse paramLabels (zip [1 ..] q.params)) + <*> (concat <$> traverse columnLabels (zip3 [1 ..] (concat q.row) (map fst found))) + else pure [] + pure (paramErrors <> columnErrors <> sentErrors <> labelErrors) + where + -- A label the database does not have fails to be sent; one the Haskell + -- type does not have fails to be read. + paramLabels (n :: Int, c) = labelsAgainst c \enum labels -> + [ concat ["parameter $", show n, " is sent as ", Text.unpack c.haskellType, ", with labels ", Text.unpack enum, " does not have: ", list missing] + | let missing = filter (`notElem` labels) c.labels + , not (null missing) + ] + columnLabels (i :: Int, c, name) = labelsAgainst c \enum labels -> + [ concat ["column ", show i, " (", name, ") is read as ", Text.unpack c.haskellType, ", which cannot read labels ", Text.unpack enum, " has: ", list missing] + | let missing = filter (`notElem` c.labels) labels + , not (null missing) + ] + labelsAgainst c compare' + | null c.labels = pure [] + | otherwise = + enumLabels c.postgres <&> \case + Nothing -> [Text.unpack c.postgres <> " is sent and read as an enum, but is not one in the database"] + Just labels -> compare' c.postgres labels + list = Text.unpack . Text.intercalate ", " + -- The labels of the enum a type is, through any domains over it and + -- arrays of it. + enumLabels name = + query + conn + ( mconcat + [ "WITH RECURSIVE t (oid, typtype, typcategory, typbasetype, typelem) AS (" + , "SELECT oid, typtype, typcategory, typbasetype, typelem FROM pg_catalog.pg_type WHERE oid = to_regtype(" + , quoteLiteral name + , ") UNION ALL SELECT p.oid, p.typtype, p.typcategory, p.typbasetype, p.typelem FROM pg_catalog.pg_type p, t" + , " WHERE p.oid = CASE WHEN t.typtype = 'd' THEN t.typbasetype WHEN t.typcategory = 'A' THEN t.typelem END)" + , " SELECT e.enumlabel FROM pg_catalog.pg_enum e WHERE e.enumtypid = (SELECT oid FROM t WHERE typtype = 'e')" + , " ORDER BY e.enumsortorder" + ] + ) + <&> \case + Right [] -> Nothing + Right rows -> Just [Text.decodeUtf8Lenient l | [Just l] <- rows] + Left _ -> Nothing + described sql paramOids = do + prepared <- conn.prepare "" (Text.encodeUtf8 sql) (Just paramOids) + case prepared of + Nothing -> Left . maybe "Something went wrong" (Text.unpack . Text.decodeUtf8Lenient) <$> conn.errorMessage + Just result -> do + status <- result.resultStatus + if status /= Pqi.CommandOk + then Left . maybe "Something went wrong" (Text.unpack . Text.decodeUtf8Lenient) <$> result.resultErrorMessage + else + conn.describePrepared "" >>= \case + Nothing -> Left . maybe "Something went wrong" (Text.unpack . Text.decodeUtf8Lenient) <$> conn.errorMessage + Just d -> do + n <- d.nfields + found <- traverse (\i -> (,) <$> (maybe "?column?" (Text.unpack . Text.decodeUtf8Lenient) <$> d.fname i) <*> d.ftype i) [0 .. n - 1] + pure (Right found) + -- A literal is converted once and for all: try it. + literalError i name c literal = + query conn (Text.encodeUtf8 (mconcat ["SELECT (", literal, ") :: ", c.postgres])) <&> \case + Right _ -> [] + Left err -> [concat ["column ", show i, " (", name, ") is ", Text.unpack literal, ", which cannot be read as ", Text.unpack c.haskellType, ": ", err]] + conversionError i name c from to = do + converts <- convertsWithoutBeingTold from to + fromName <- nameOf from + toName <- nameOf to + pure + [ concat + [ "column " + , show i + , " (" + , name + , ") is " + , fromName + , ", but is read as " + , Text.unpack c.haskellType + , " (" + , toName + , "), which Postgres converts it to only when told to, and can fail to at runtime" + ] + | not converts + ] + -- Through their base types, so that a domain converts as the type it is + -- over; and an array as its elements, as Postgres converts arrays. + convertsWithoutBeingTold :: Word32 -> Word32 -> IO Bool + convertsWithoutBeingTold from to = + query + conn + ( mconcat + [ "SELECT f.typelem::text, t.typelem::text FROM pg_catalog.pg_type f, pg_catalog.pg_type t" + , " WHERE f.oid = " + , base from + , " AND t.oid = " + , base to + , " AND f.typcategory = 'A' AND t.typcategory = 'A'" + ] + ) + >>= \case + Right [[Just f, Just t]] + | Just f' <- readMaybe (ByteString.Char8.unpack f) + , Just t' <- readMaybe (ByteString.Char8.unpack t) -> + convertsWithoutBeingTold f' t' + _ -> scalarConverts from to + scalarConverts from to = + query + conn + ( mconcat + [ "SELECT (SELECT castcontext::text FROM pg_catalog.pg_cast WHERE castsource = " + , base from + , " AND casttarget = " + , base to + , "), " + , base from + , " = " + , base to + , ", (SELECT typcategory = 'S' FROM pg_catalog.pg_type WHERE oid = " + , base to + , ")" + ] + ) + >>= \case + Right [[context, same, toString]] -> pure (same == Just "t" || toString == Just "t" || context `elem` [Just "i", Just "a"]) + _ -> pure False + -- Through every domain a domain is over. + base o = + mconcat + [ "(WITH RECURSIVE d (oid, typtype, typbasetype) AS (SELECT oid, typtype, typbasetype FROM pg_catalog.pg_type WHERE oid = " + , ByteString.Char8.pack (show o) + , " UNION ALL SELECT t.oid, t.typtype, t.typbasetype FROM pg_catalog.pg_type t, d WHERE t.oid = d.typbasetype AND d.typtype = 'd')" + , " SELECT oid FROM d WHERE typtype <> 'd')" + ] + sameBase from to = + query conn (mconcat ["SELECT ", base from, " = ", base to]) <&> \case + Right [[Just "t"]] -> True + _ -> False + count :: String -> Int -> String + count what 1 = "1 " <> what + count what k = unwords [show k, what <> "s"] + oid :: Text -> IO (Maybe Word32) + oid name = + query conn (mconcat ["SELECT to_regtype(", quoteLiteral name, ")::oid::text"]) >>= \case + Right [[Just o]] -> pure (readMaybe (ByteString.Char8.unpack o)) + _ -> pure Nothing + nameOf :: Word32 -> IO String + nameOf o = + query conn (mconcat ["SELECT ", ByteString.Char8.pack (show o), "::regtype::text"]) >>= \case + Right [[Just name]] -> pure (Text.unpack (Text.decodeUtf8Lenient name)) + _ -> pure ("type " <> show o) + quoteLiteral name = mconcat ["'", Text.encodeUtf8 (Text.replace "'" "''" name), "'"] + + +zip4 :: [a] -> [b] -> [c] -> [d] -> [(a, b, c, d)] +zip4 (a : as) (b : bs) (c : cs) (d : ds) = (a, b, c, d) : zip4 as bs cs ds +zip4 _ _ _ _ = [] diff --git a/src/Hasql/Check/Inferred/TH.hs b/src/Hasql/Check/Inferred/TH.hs new file mode 100644 --- /dev/null +++ b/src/Hasql/Check/Inferred/TH.hs @@ -0,0 +1,129 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | +-- Module : Hasql.Check.Inferred.TH +-- Copyright : (c) 2026 Kronor.io +-- +-- License : BSD-3-Clause +-- Maintainer : lorenzo@kronor.io +-- Stability : experimental +-- Portability : GHC +-- +-- Quoters for SQL without annotations: the Haskell types a statement is used +-- with decide its parameter and result types. +-- +-- > profile :: Statement Int64 (Maybe (Text, Maybe Text)) +-- > profile = [maybeStatement| select email, nickname from customer where id = $1 |] +-- +-- sends +-- +-- > WITH hasql_check_result (c1, c2) AS (SELECT email, nickname FROM customer WHERE id = $1 :: int8) +-- > SELECT c1 :: text, c2 :: text FROM hasql_check_result +-- +-- GHC can only tell whether those types fit the schema with a database; see +-- the README for checking them with @hasql-check --inferred@. +module Hasql.Check.Inferred.TH ( + singletonStatement, + maybeStatement, + vectorStatement, + resultlessStatement, + template, +) where + +import Data.Char (isAlphaNum) +import Data.Text (Text) +import Data.Text qualified as Text +import Data.Text.Encoding qualified as Text +import Hasql.Check (parsePlainStmt, renderStmt) +import Hasql.Check.Annotate (annotate, placeholder) +import Hasql.Check.Inferred (Piece (..), Template (..), Wrapped (..), resultless, statement) +import Hasql.Decoders qualified as D +import Language.Haskell.TH (Exp, Q) +import Language.Haskell.TH.Quote (QuasiQuoter (..)) +import Language.Haskell.TH.Syntax (lift) +import PostgresqlSyntax qualified as Ast +import Text.Read (readMaybe) +import Prelude + + +quoter :: (Q Exp -> Q Exp) -> QuasiQuoter +quoter make = + QuasiQuoter + { quoteExp = either fail (make . lift) . template . Text.pack + , quotePat = const (fail "Not supported in patterns") + , quoteType = const (fail "Not supported in types") + , quoteDec = const (fail "Not supported in declarations") + } + + +singletonStatement, maybeStatement, vectorStatement, resultlessStatement :: QuasiQuoter +singletonStatement = quoter \t -> [|statement $t D.singleRow|] +maybeStatement = quoter \t -> [|statement $t D.rowMaybe|] +vectorStatement = quoter \t -> [|statement $t D.rowVector|] +resultlessStatement = quoter \t -> [|resultless $t|] + + +-- | The statement, rendered as hasql-th would render it, cut where its +-- parameters' annotations go, and split where its result columns' cast +-- goes around it. +template :: Text -> Either String Template +template sql = do + stmt <- parsePlainStmt False sql + -- Names the statement does not already contain, in a string literal or + -- as a table, say. + let plain = Text.toLower (Text.decodeUtf8Lenient (renderStmt stmt)) + unused base = until (not . (`Text.isInfixOf` plain)) (<> "_") base + prefix = unused "hasql_check_slot_" + annotated = annotate (\n -> Just (placeholder (prefix <> Text.pack (show n)))) stmt + cut = cutWith prefix + pure + Template + { whole = cut (Text.decodeUtf8Lenient (renderStmt annotated)) + , wrapped = + ( \(with, body) -> + Wrapped + { with = cut . Ast.toText mempty <$> with + , body = cut (Text.decodeUtf8Lenient (renderStmt body)) + , name = unused "hasql_check_result" + } + ) + <$> splitWith annotated + } + + +-- | The statement's own WITH list, and the rest of it. +splitWith :: Ast.PreparableStmt -> Maybe (Maybe Ast.WithClause, Ast.PreparableStmt) +splitWith = \case + -- "(WITH ... SELECT ...)" is a parenthesised select clause. + Ast.SelectPreparableStmt (Ast.NoParensSelectStmt (Ast.SelectNoParens Nothing (Ast.WithParensSelectClause p) s l f)) -> + let (w, p') = inParens p + in Just (w, Ast.SelectPreparableStmt (Ast.NoParensSelectStmt (Ast.SelectNoParens Nothing (Ast.WithParensSelectClause p') s l f))) + Ast.SelectPreparableStmt (Ast.NoParensSelectStmt (Ast.SelectNoParens w c s l f)) -> + Just (w, Ast.SelectPreparableStmt (Ast.NoParensSelectStmt (Ast.SelectNoParens Nothing c s l f))) + Ast.SelectPreparableStmt (Ast.WithParensSelectStmt s) -> Just (Ast.SelectPreparableStmt . Ast.WithParensSelectStmt <$> inParens s) + Ast.InsertPreparableStmt (Ast.InsertStmt w a b c d) -> Just (w, Ast.InsertPreparableStmt (Ast.InsertStmt Nothing a b c d)) + Ast.UpdatePreparableStmt (Ast.UpdateStmt w a b c d e) -> Just (w, Ast.UpdatePreparableStmt (Ast.UpdateStmt Nothing a b c d e)) + Ast.DeletePreparableStmt (Ast.DeleteStmt w a b c d) -> Just (w, Ast.DeletePreparableStmt (Ast.DeleteStmt Nothing a b c d)) + Ast.CallPreparableStmt _ -> Nothing + + +-- | A parenthesised SELECT's WITH list, and the rest of it: the list can go +-- outside the parentheses, and must, if it has a data-modifying statement. +inParens :: Ast.SelectWithParens -> (Maybe Ast.WithClause, Ast.SelectWithParens) +inParens = \case + Ast.NoParensSelectWithParens (Ast.SelectNoParens w c s l f) -> (w, Ast.NoParensSelectWithParens (Ast.SelectNoParens Nothing c s l f)) + Ast.WithParensSelectWithParens s -> Ast.WithParensSelectWithParens <$> inParens s + + +cutWith :: Text -> Text -> [Piece] +cutWith prefix = cut + where + cut t = case Text.breakOn (" :: " <> prefix) t of + (before, "") -> [Sql before | not (Text.null before)] + (before, rest) -> + let (slot, after) = Text.span isAlphaNum (Text.drop (Text.length (" :: " <> prefix)) rest) + in [Sql before | not (Text.null before)] <> piece slot <> cut after + + piece slot = case readMaybe (Text.unpack slot) of + Just i -> [ParamType i] + Nothing -> [Sql (" :: " <> prefix <> slot)] diff --git a/src/Hasql/Check/Lexer.x b/src/Hasql/Check/Lexer.x new file mode 100644 --- /dev/null +++ b/src/Hasql/Check/Lexer.x @@ -0,0 +1,276 @@ + +{ + +{-# LANGUAGE NoStrictData #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} + +module Hasql.Check.Lexer where + +import Prelude +import Control.Monad (when) +import Data.Maybe (isJust, fromJust) +import Data.ByteString.Builder (Builder) +import qualified Data.ByteString.Builder as ByteString.Builder +import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Lazy as ByteString.Lazy +import qualified Data.ByteString.Lazy.Char8 as ByteString.Lazy.Char8 +import Data.Text (Text) +import qualified Data.Text.Encoding as Text.Encoding +import System.Directory + +} + +%wrapper "monadUserState-bytestring" + +$digit = 0-9 -- digits +$small = [a-z_] +$large = [A-Z] +$alpha = [A-Za-z] +$idchar = [$alpha $digit _ \'] -- identifier character +$symbol = [\!\#\$\%\&\*\+\.\/\<\=\>\?\@\\\^\|\-\~\:] -- ascii operator symbols +$pipe = \| +$rbrack = \] +$lbrack = \[ + +@varid = $small $idchar* +@modid = $large $idchar* +-- GHC accepts a qualified quoter, [Hasql.TH.vectorStatement| ... |], as well +-- as a bare one. +@quoter = (@modid \.)* @varid +@beginquote = $lbrack @quoter $pipe +@endquote = $pipe $rbrack +-- A string gap: a backslash, whitespace including newlines, a backslash. +@gap = \\ $white+ \\ +@charlit = \' ( [^\\ \' \n] | \\ [^\n] [^\' \n]* ) \' + +tokens :- +<0> @beginquote { enterQuote `andBegin` state_quote } +<0> \n { skip } +-- Identifiers are consumed whole so the prime in x' is never read as the start +-- of a character literal. +<0> [$alpha \_] $idchar* { skip } +-- Literals are skipped so that "{-", "--" or "[x|" inside one cannot open a +-- comment or a quote and hide the quotes that follow it. +<0> @charlit { skip } +<0> \"\"\" { skip `andBegin` state_multiline_string } +<0> \" { skip `andBegin` state_string } + @gap { skip } + \\ . { skip } + \" { skip `andBegin` state_initial } + \n { skip } + . { skip } + \\ . { skip } + \"\"\" { skip `andBegin` state_initial } + \n { skip } + . { skip } +-- A run of dashes followed by a symbol is an operator such as --> rather than +-- a comment. +<0> "--" \-* / ~$symbol { skip `andBegin` state_line_comment } + \n { skip `andBegin` state_initial } + . { skip } +<0> "{-" { enterNewComment `andBegin` state_multi_comment } +<0> . { skip } + "{-" { embedComment } + "-}" { unembedComment } + \n { skip } + . { skip } + \n { addCurrentToQuote } + . { addCurrentToQuote } + @endquote { leaveQuote `andBegin` state_initial } + +{ +data Lexeme = Lexeme AlexPosn LexemeClass + deriving (Show, Eq) + +data LexemeClass = + Eof + | Quoter Text + | Quote Text + deriving (Show, Eq) + +mkLexemeClass :: LexemeClass -> AlexInput -> Int64 -> Alex Lexeme +mkLexemeClass c (p, _, _, _) _ = return (Lexeme p c) + +-- states +state_initial :: Int +state_initial = 0 + +-- user state type + +data AlexUserState = AlexUserState + { lexerCommentDepth :: Int + , lexerQuoterState :: Bool + , lexerQuoterValue :: Builder + , lexerQuoteState :: Bool + , lexerQuoteValue :: Builder + } + +alexInitUserState :: AlexUserState +alexInitUserState = AlexUserState + { lexerCommentDepth = 0 + , lexerQuoterState = False + , lexerQuoterValue = mempty + , lexerQuoteState = False + , lexerQuoteValue = mempty + } + +getLexerCommentDepth :: Alex Int +getLexerCommentDepth = Alex $ \s@AlexState{alex_ust = ust} -> Right (s, lexerCommentDepth ust) + +setLexerCommentDepth :: Int -> Alex () +setLexerCommentDepth depth = Alex $ \s -> Right (s{alex_ust = (alex_ust s){lexerCommentDepth = depth}}, ()) + +enterNewComment :: AlexInput -> Int64 -> Alex Lexeme +enterNewComment input len = do + setLexerCommentDepth 1 + skip input len + +embedComment :: AlexInput -> Int64 -> Alex Lexeme +embedComment input len = do + d <- getLexerCommentDepth + setLexerCommentDepth (d + 1) + skip input len + +unembedComment :: AlexInput -> Int64 -> Alex Lexeme +unembedComment input len = do + d <- getLexerCommentDepth + setLexerCommentDepth (d - 1) + if d == 1 + then do + (skip `andBegin` state_initial) input len + else skip input len + +getLexerQuoteState :: Alex Bool +getLexerQuoteState = Alex $ \s@AlexState{alex_ust = ust} -> Right (s, lexerQuoteState ust) + +getLexerQuoterState :: Alex Bool +getLexerQuoterState = Alex $ \s@AlexState{alex_ust = ust} -> Right (s, lexerQuoterState ust) + +setLexerQuoteState :: Bool -> Alex () +setLexerQuoteState quoteState = + Alex $ \s -> Right (s{alex_ust = (alex_ust s){lexerQuoteState = quoteState}}, ()) + +setLexerQuoterState :: Bool -> Alex () +setLexerQuoterState quoterState = + Alex $ \s -> Right (s{alex_ust = (alex_ust s){lexerQuoterState = quoterState}}, ()) + +getLexerQuoteValue :: Alex Builder +getLexerQuoteValue = Alex $ \s@AlexState{alex_ust = ust} -> Right (s, lexerQuoteValue ust) + +setLexerQuoteValue :: Builder -> Alex () +setLexerQuoteValue builder = Alex $ \s -> Right (s{alex_ust = (alex_ust s){lexerQuoteValue = builder}}, ()) + +getLexerQuoterValue :: Alex Builder +getLexerQuoterValue = Alex $ \s@AlexState{alex_ust = ust} -> Right (s, lexerQuoterValue ust) + +setLexerQuoterValue :: Builder -> Alex () +setLexerQuoterValue builder = Alex $ \s -> Right (s{alex_ust = (alex_ust s){lexerQuoterValue = builder}}, ()) + +addCurrentToQuote :: AlexInput -> Int64 -> Alex Lexeme +addCurrentToQuote (_, _, bytestring, _) len = do + builder <- getLexerQuoteValue + setLexerQuoteValue (builder <> ByteString.Builder.lazyByteString (ByteString.Lazy.take len bytestring)) + alexMonadScan + +enterQuote :: AlexInput -> Int64 -> Alex Lexeme +enterQuote input len = do + setLexerQuoteState True + setLexerQuoteValue mempty + addQuoter input len + +leaveQuote :: AlexInput -> Int64 -> Alex Lexeme +leaveQuote (posn, _, _, _) _ = do + builder <- getLexerQuoteValue + setLexerQuoteState False + setLexerQuoterState False + case Text.Encoding.decodeUtf8' (ByteString.Lazy.toStrict (ByteString.Builder.toLazyByteString builder)) of + Left e -> lexerError $ "Malformed utf8 string: " <> show e + Right string -> pure $ Lexeme posn (Quote string) + +addQuoter :: AlexInput -> Int64 -> Alex Lexeme +addQuoter (posn, _, bytestring, _) len = do + let bsVariable = ByteString.Lazy.dropEnd 1 (ByteString.Lazy.drop 1 (ByteString.Lazy.take len bytestring)) + case Text.Encoding.decodeUtf8' (ByteString.Lazy.toStrict bsVariable) of + Right var -> do + pure $ Lexeme posn (Quoter var) + Left e -> lexerError $ "Malformed utf8 representation of quoter, expecting unicode: " <> show e + +getPosn :: Alex AlexPosn +getPosn = Alex $ \s@AlexState{alex_pos = posn} -> Right (s, posn) + +alexEOF :: Alex Lexeme +alexEOF = flip Lexeme Eof <$> getPosn + +showPosn :: AlexPosn -> String +showPosn (AlexPn _ line col) = show line ++ ':': show col + +-- the error message doesn't do a utf8 decoding of the input. +lexerError :: String -> Alex a +lexerError msg = + do (p, c, inp, _) <- alexGetInput + let inp1 = ByteString.Lazy.Char8.filter (/= '\r') (ByteString.Lazy.Char8.takeWhile (/='\n') inp) + let inp2 = if (ByteString.Lazy.length inp1 > 30) + then trimBSL (ByteString.Lazy.take 30 inp1) + else trimBSL inp1 + let disp = if (ByteString.Lazy.null inp) + then " at end of file" + else if (ByteString.Lazy.null inp2) + then " before end of line" + else " on char " ++ show c ++ " before : '" ++ ByteString.Lazy.Char8.unpack inp2 ++ "'" + let disp3 = if (null msg) + then "Lexer error" + else trim msg + alexError (disp3 ++ " at " ++ showPosn p ++ disp) + where + trim = reverse . dropWhile (== ' ') . reverse . dropWhile (== ' ') + trimBSL = ByteString.Lazy.Char8.takeWhile (/= ' ') . ByteString.Lazy.Char8.dropWhile (== ' ') + +-- Execution + +scanner :: ByteString -> Either String [Lexeme] +scanner str = let loop = do (t, m) <- alexComplementError alexMonadScan + when (isJust m) (lexerError (fromJust m)) + let tok@(Lexeme _ cl) = t + if (cl == Eof) + then do f1 <- getLexerQuoterState + d2 <- getLexerQuoteState + if ((not f1) && (not d2)) + then return [tok] + else alexError "Quote not closed at end of file" + else do toks <- loop + return (tok : toks) + in runAlex str loop + +-- we capture the error message in order to complement it with the file position +alexComplementError :: Alex a -> Alex (a, Maybe String) +alexComplementError (Alex al) = Alex $ \s -> + case al s of + Right (s', x) -> Right (s', (x, Nothing)) + Left message -> Right (s, (undefined, Just message)) + + +lexer :: (Lexeme -> Alex a) -> Alex a +lexer f = do + (t, m) <- alexComplementError alexMonadScan + when (isJust m) (lexerError (fromJust m)) + let tok@(Lexeme _ cl) = t + if (cl == Eof) + then do + f1 <- getLexerQuoterState + d2 <- getLexerQuoteState + if ((not f1) && (not d2)) + then f tok + else alexError "Quote not closed at end of file" + else f tok + +lexFile :: FilePath -> IO (Either String [Lexeme]) +lexFile fn = do + flag <- doesFileExist fn + if not flag + then pure $ Left ("The following file does not exist : " ++ fn) + else do + putStrLn ("Beginning analysis of the hasql-th quotes in file " ++ fn) + s <- ByteString.Lazy.readFile fn + pure (reverse <$> scanner s) + +} diff --git a/src/Hasql/Check/Nullability.hs b/src/Hasql/Check/Nullability.hs new file mode 100644 --- /dev/null +++ b/src/Hasql/Check/Nullability.hs @@ -0,0 +1,530 @@ +{-# LANGUAGE CPP #-} + +-- | +-- Module : Hasql.Check.Nullability +-- Copyright : (c) 2026 Kronor.io +-- +-- License : BSD-3-Clause +-- Maintainer : lorenzo@kronor.io +-- Stability : experimental +-- Portability : GHC +-- +-- Warn about result columns annotated non-null that can be null. +-- +-- The annotation on a result column is a cast, and a cast hides where the +-- column came from, so the statement is prepared a second time with the +-- outermost cast of every result column removed. Postgres then reports, for +-- each plain column reference, the table and column it reads, and the +-- catalogue says whether that column is @NOT NULL@. +-- +-- The plan of that statement adds two things. Columns from the nullable side +-- of an outer join can be null whatever the catalogue says, as sqlx also +-- finds. And a column the plan filters with @IS NOT NULL@ cannot be null, +-- whatever the catalogue says. The plan rather than the statement's own +-- @WHERE@ clause is used for the second because the plan has the +-- conditions after Postgres has resolved precedence, pushed them down and +-- turned outer joins they make inner into inner joins. +-- +-- Anything else - expressions, views - is not checked: Postgres does not say +-- whether they can be null. +module Hasql.Check.Nullability ( + Catalogue, + baseType, + prepareSession, + Annotation (..), + strip, + query, + check, + checkColumns, + resultQuoters, +) where + +import Control.Exception (finally) +import Control.Monad (forM) +import Data.Aeson ((.:), (.:?)) +import Data.Aeson qualified as Aeson +import Data.Bifunctor (second) +import Data.ByteString (ByteString) +import Data.ByteString.Char8 qualified as ByteString.Char8 +import Data.Data (Data, cast, gmapT) +import Data.Foldable (toList) +import Data.Int (Int32) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Maybe (catMaybes, fromMaybe, mapMaybe) +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Text (Text) +import Data.Text qualified as Text +import Data.Text.Encoding qualified as Text +import Data.Word (Word32) +import Hasql.Check (renderStmt) +import Hasql.Check.Finding (Finding (..), Rule (..)) +import PostgresqlSyntax qualified as Ast +import Pqi qualified +import Text.Read (readMaybe) +import Prelude + + +-- | The quoters whose statements return rows. +resultQuoters :: [Text] +resultQuoters = ["singletonStatement", "maybeStatement", "vectorStatement", "foldStatement"] + + +-- * The catalogue + + +data Column = Column + { qualifiedName :: Text + , notNull :: Bool + , fromView :: Bool + -- ^ A view's or materialized view's column, whose @attnotnull@ is always + -- false and so says nothing. + } + + +data Catalogue = Catalogue + { columns :: Map (Word32, Int32) Column + -- ^ Every column of every relation, by table OID and column number. + , domains :: Map Word32 Word32 + -- ^ The base type of every domain. + } + + +-- | A type with any domains it is built on looked through. +baseType :: Catalogue -> Word32 -> Word32 +baseType catalogue t = maybe t (baseType catalogue) (Map.lookup t catalogue.domains) + + +-- | Get the session ready for 'check': read the catalogue, and force generic +-- plans, so that EXPLAIN EXECUTE with NULL parameters shows the plan for any +-- parameters rather than one with the NULLs folded in. +prepareSession :: Pqi.Connection -> IO (Either String Catalogue) +prepareSession conn = do + generic <- query conn "SET plan_cache_mode = force_generic_plan" + catalogue <- loadCatalogue conn + pure (generic *> catalogue) + + +loadCatalogue :: Pqi.Connection -> IO (Either String Catalogue) +loadCatalogue conn = do + result <- + query + conn + ( ByteString.Char8.unwords + [ "SELECT a.attrelid::text, a.attnum::text, n.nspname || '.' || c.relname || '.' || a.attname," + , "a.attnotnull::text, (c.relkind IN ('v', 'm'))::text" + , "FROM pg_catalog.pg_attribute a" + , "JOIN pg_catalog.pg_class c ON c.oid = a.attrelid" + , "JOIN pg_catalog.pg_namespace n ON n.oid = c.relnamespace" + , "WHERE a.attnum > 0 AND NOT a.attisdropped" + ] + ) + domainRows <- query conn "SELECT oid::text, typbasetype::text FROM pg_catalog.pg_type WHERE typtype = 'd'" + pure do + rows <- result + columns <- Map.fromList <$> traverse row rows + domains <- Map.fromList <$> (domainRows >>= traverse domain) + pure (Catalogue columns domains) + where + domain = \case + [Just t, Just base] + | Just t' <- readMaybe (ByteString.Char8.unpack t) + , Just base' <- readMaybe (ByteString.Char8.unpack base) -> + Right (t', base') + other -> Left ("Unexpected domain row: " <> show other) + row = \case + [Just rel, Just num, Just name, Just nn, Just view] + | Just rel' <- readMaybe (ByteString.Char8.unpack rel) + , Just num' <- readMaybe (ByteString.Char8.unpack num) -> + Right ((rel', num'), Column (Text.decodeUtf8Lenient name) (nn == "true") (view == "true")) + other -> Left ("Unexpected catalogue row: " <> show other) + + +-- * Stripping the result casts + + +-- | A result column's outermost cast, if it has one: its nullability, and the +-- expression with and without it. +data Annotation = Annotation + { nullable :: Maybe Bool + , removed :: Maybe (Ast.AExpr, Ast.AExpr) + } + + +typenameNullable :: Ast.Typename -> Bool +typenameNullable (Ast.Typename _ _ nullable dims) = maybe nullable snd dims + + +stripExpr :: Ast.AExpr -> (Annotation, Ast.AExpr) +stripExpr = \case + whole@(Ast.TypecastAExpr e t) -> (Annotation (Just (typenameNullable t)) (Just (whole, e)), e) + e -> (Annotation Nothing Nothing, e) + + +stripTargetEl :: Ast.TargetEl -> Maybe (Annotation, Ast.TargetEl) +stripTargetEl = \case + Ast.AliasedExprTargetEl a i -> Just (second (`Ast.AliasedExprTargetEl` i) (stripExpr a)) + Ast.ImplicitlyAliasedExprTargetEl a i -> Just (second (`Ast.ImplicitlyAliasedExprTargetEl` i) (stripExpr a)) + Ast.ExprTargetEl a -> Just (second Ast.ExprTargetEl (stripExpr a)) + Ast.AsteriskTargetEl -> Nothing + + +stripTargetList :: Ast.TargetList -> Maybe ([Annotation], Ast.TargetList) +stripTargetList (Ast.TargetList els) = do + stripped <- traverse stripTargetEl els + pure (map fst (toList stripped), Ast.TargetList (fmap snd stripped)) + +#ifdef KRONOR_SYNTAX + +-- | Kronor's fork keeps the select list as Haskell targets; once erased, every +-- one of them is a plain SQL target. +stripNormalTargeting :: Ast.HsTargetList -> Maybe ([Annotation], Ast.Targeting) +stripNormalTargeting (Ast.HsTargetList els) = do + stripped <- traverse one els + pure (map fst (toList stripped), Ast.NormalTargeting (Ast.HsTargetList (fmap snd stripped))) + where + one = \case + Ast.SqlTargetEl te -> second Ast.SqlTargetEl <$> stripTargetEl te + _ -> Nothing + +#else + +stripNormalTargeting :: Ast.TargetList -> Maybe ([Annotation], Ast.Targeting) +stripNormalTargeting l = second Ast.NormalTargeting <$> stripTargetList l + +#endif + + +stripTargeting :: Ast.Targeting -> Maybe ([Annotation], Ast.Targeting) +stripTargeting = \case + Ast.NormalTargeting l -> stripNormalTargeting l + Ast.AllTargeting (Just l) -> second (Ast.AllTargeting . Just) <$> stripTargetList l + Ast.DistinctTargeting e l -> second (Ast.DistinctTargeting e) <$> stripTargetList l + Ast.AllTargeting Nothing -> Nothing + + +stripSimple :: Ast.SimpleSelect -> Maybe ([Annotation], Ast.SimpleSelect) +stripSimple = \case + Ast.NormalSimpleSelect (Just t) b c d e f g -> second (\t' -> Ast.NormalSimpleSelect (Just t') b c d e f g) <$> stripTargeting t + _ -> Nothing + + +stripClause :: Ast.SelectClause -> Maybe ([Annotation], Ast.SelectClause) +stripClause = \case + Ast.SimpleSelectSelectClause s -> second Ast.SimpleSelectSelectClause <$> stripSimple s + Ast.WithParensSelectClause s -> second Ast.WithParensSelectClause <$> stripWithParens s + + +stripNoParens :: Ast.SelectNoParens -> Maybe ([Annotation], Ast.SelectNoParens) +stripNoParens (Ast.SelectNoParens a c s l f) = second (\c' -> Ast.SelectNoParens a c' s l f) <$> stripClause c + + +stripWithParens :: Ast.SelectWithParens -> Maybe ([Annotation], Ast.SelectWithParens) +stripWithParens = \case + Ast.NoParensSelectWithParens s -> second Ast.NoParensSelectWithParens <$> stripNoParens s + Ast.WithParensSelectWithParens s -> second Ast.WithParensSelectWithParens <$> stripWithParens s + + +stripReturning :: Maybe Ast.ReturningClause -> Maybe ([Annotation], Maybe Ast.ReturningClause) +stripReturning = \case + Just (Ast.ReturningClause l) -> second (Just . Ast.ReturningClause) <$> stripTargetList l + Nothing -> Nothing + + +-- | The annotation of every result column, and the statement without them. +-- +-- An annotated expression is replaced wherever it occurs, not only in the +-- result columns: @select distinct amount :: int4 ... order by amount :: int4@ +-- would otherwise order by an expression it no longer selects, and fail to +-- prepare. +strip :: Ast.PreparableStmt -> Maybe ([Annotation], Ast.PreparableStmt) +strip stmt = do + (annotations, stripped) <- stripResults stmt + let replacements = [r | Annotation{removed = Just r} <- annotations] + pure (annotations, replaceEverywhere replacements stripped) + + +-- | Replace every occurrence of the given expressions. +replaceEverywhere :: Data a => [(Ast.AExpr, Ast.AExpr)] -> a -> a +replaceEverywhere [] = id +replaceEverywhere replacements = go + where + go :: Data b => b -> b + go x = case cast x of + Just e | Just replacement <- lookup e replacements, Just r <- cast replacement -> r + _ -> gmapT go x + + +stripResults :: Ast.PreparableStmt -> Maybe ([Annotation], Ast.PreparableStmt) +stripResults = \case + Ast.SelectPreparableStmt (Ast.NoParensSelectStmt s) -> second (Ast.SelectPreparableStmt . Ast.NoParensSelectStmt) <$> stripNoParens s + Ast.SelectPreparableStmt (Ast.WithParensSelectStmt s) -> second (Ast.SelectPreparableStmt . Ast.WithParensSelectStmt) <$> stripWithParens s + Ast.InsertPreparableStmt (Ast.InsertStmt a b c d r) -> second (Ast.InsertPreparableStmt . Ast.InsertStmt a b c d) <$> stripReturning r + Ast.UpdatePreparableStmt (Ast.UpdateStmt a b c d e r) -> second (Ast.UpdatePreparableStmt . Ast.UpdateStmt a b c d e) <$> stripReturning r + Ast.DeletePreparableStmt (Ast.DeleteStmt a b c d r) -> second (Ast.DeletePreparableStmt . Ast.DeleteStmt a b c d) <$> stripReturning r + Ast.CallPreparableStmt _ -> Nothing + + +-- * The plan + + +data Plan = Plan + { nodeType :: Text + , output :: [Text] + , joinType :: Maybe Text + , parentRelationship :: Maybe Text + , filters :: [Text] + -- ^ The conditions applied to the node's own rows. Not its join filter, + -- which on an outer join only decides what matches. + , plans :: [Plan] + } + + +instance Aeson.FromJSON Plan where + parseJSON = Aeson.withObject "Plan" \o -> do + filters <- catMaybes <$> traverse (o .:?) ["Filter", "Index Cond", "Recheck Cond"] + Plan + <$> (fromMaybe "" <$> o .:? "Node Type") + <*> (fromMaybe [] <$> o .:? "Output") + <*> o .:? "Join Type" + <*> o .:? "Parent Relationship" + <*> pure filters + <*> (fromMaybe [] <$> o .:? "Plans") + + +newtype Explained = Explained Plan + + +instance Aeson.FromJSON Explained where + parseJSON = Aeson.withObject "EXPLAIN" \o -> Explained <$> o .: "Plan" + + +-- | What the plan says about the nullability of the expressions it outputs. +data PlanNullability = PlanNullability + { outerJoined :: Set Text + -- ^ Output by a node on the nullable side of an outer join: the inner side + -- of a left join, the outer side of a right join, both sides of a full one. + , filteredNotNull :: Set Text + -- ^ Filtered with @IS NOT NULL@ by a node whose condition holds for every + -- row: not one on such a side, under one branch of a @BitmapOr@, or in a + -- subplan, whose rows are not the statement's. + } + + +instance Semigroup PlanNullability where + PlanNullability a b <> PlanNullability c d = PlanNullability (a <> c) (b <> d) + + +instance Monoid PlanNullability where + mempty = PlanNullability Set.empty Set.empty + + +planNullability :: Plan -> PlanNullability +planNullability = go False True + where + go nullable guarding plan = + PlanNullability + (if nullable then Set.fromList plan.output else Set.empty) + (if guarding && not nullable then Set.fromList (concatMap notNullOperands plan.filters) else Set.empty) + <> foldMap + ( \child -> + go + (nullable || nullableChild plan child) + (guarding && plan.nodeType /= "BitmapOr" && child.parentRelationship `notElem` [Just "SubPlan", Just "InitPlan"]) + child + ) + plan.plans + nullableChild parent child = case parent.joinType of + Just "Left" -> child.parentRelationship == Just "Inner" + Just "Right" -> child.parentRelationship == Just "Outer" + Just "Full" -> True + _ -> False + + +-- | The operands of the @IS NOT NULL@ conjuncts of a condition as EXPLAIN +-- prints it: @((a.id > 0) AND (a.nickname IS NOT NULL))@ gives @a.nickname@. +notNullOperands :: Text -> [Text] +notNullOperands = mapMaybe (Text.stripSuffix " IS NOT NULL" . unwrap) . conjuncts . unwrap + where + conjuncts = splitTopLevel " AND " + + +-- | Drop parentheses around the whole of an expression. +unwrap :: Text -> Text +unwrap t + | Just inner <- Text.stripPrefix "(" t >>= Text.stripSuffix ")" + , balanced inner = + unwrap inner + | otherwise = t + where + balanced = all (>= 0) . depths + + +-- | The nesting depth after each character. The inside of a quoted literal or +-- identifier counts as one deeper, so nothing in it is ever at the top level. +depths :: Text -> [Int] +depths = go 0 Nothing . Text.unpack + where + go :: Int -> Maybe Char -> String -> [Int] + go _ _ [] = [] + go d (Just q) (c : cs) + | c == q = d : go d Nothing cs + | otherwise = (d + 1) : go d (Just q) cs + go d Nothing (c : cs) = case c of + '(' -> (d + 1) : go (d + 1) Nothing cs + ')' -> (d - 1) : go (d - 1) Nothing cs + '\'' -> d : go d (Just '\'') cs + '"' -> d : go d (Just '"') cs + _ -> d : go d Nothing cs + + +-- | Split on a separator that is outside any parentheses or quotes. +splitTopLevel :: Text -> Text -> [Text] +splitTopLevel sep t = go 0 (zip [0 ..] (0 : depths t)) + where + n = Text.length sep + go start [] = [Text.drop start t] + go start ((i, d) : rest) + | d == 0 + , i >= start + , sep `Text.isPrefixOf` Text.drop i t = + Text.take (i - start) (Text.drop start t) : go (i + n) (dropWhile ((< i + n) . fst) rest) + | otherwise = go start rest + + +-- | Whether the plan mentions an output. EXPLAIN qualifies output columns only +-- when the statement reads more than one relation, but qualifies them in +-- conditions regardless, so an unqualified output matches on the column name. +mentionedIn :: Text -> Set Text -> Bool +mentionedIn out set = + out `Set.member` set + || (not ("." `Text.isInfixOf` out) && any ((== out) . Text.takeWhileEnd (/= '.')) set) + + +-- * Checking + + +data Warning = Warning + { column :: Int + -- ^ From 1. + , columnName :: Text + , reason :: Text + } + + +-- | A warning as a sentence. +describe :: Warning -> String +describe w = + concat + [ "column " + , show w.column + , " (" + , Text.unpack w.columnName + , ") is annotated non-null, but " + , Text.unpack w.reason + ] + + +-- | The name the stripped statement is prepared under, so that @EXPLAIN +-- EXECUTE@ can refer to it. +statementName :: ByteString +statementName = "hasql_check_nullability" + + +-- | The warnings for a statement that prepares. A statement this cannot take +-- apart, or whose stripped form does not prepare, gets none. +check :: Pqi.Connection -> Catalogue -> Ast.PreparableStmt -> IO [Finding] +check conn catalogue stmt = map toFinding <$> warningsFor conn catalogue stmt + where + toFinding w = Finding{rule = Nullable, subject = w.columnName, message = describe w} + + +-- | 'check', for a statement whose result columns are not annotated, given +-- whether each may be NULL: one of "Hasql.Check.Inferred.TH", whose Haskell +-- types say so. Its columns may be behind a @*@. +checkColumns :: Pqi.Connection -> Catalogue -> [Bool] -> Ast.PreparableStmt -> IO [Finding] +checkColumns conn catalogue nullables stmt = + map toFinding <$> warningsWith conn catalogue stmt ([Annotation (Just n) Nothing | n <- nullables], stmt) + where + toFinding w = Finding{rule = Nullable, subject = w.columnName, message = describe w} + + +warningsFor :: Pqi.Connection -> Catalogue -> Ast.PreparableStmt -> IO [Warning] +warningsFor conn catalogue stmt = maybe (pure []) (warningsWith conn catalogue stmt) (strip stmt) + + +warningsWith :: Pqi.Connection -> Catalogue -> Ast.PreparableStmt -> ([Annotation], Ast.PreparableStmt) -> IO [Warning] +warningsWith conn catalogue stmt = \case + (annotations, stripped) -> do + prepared <- conn.prepare statementName (renderStmt stripped) Nothing + status <- maybe (pure Pqi.FatalError) (.resultStatus) prepared + if status /= Pqi.CommandOk + then pure [] + else warnings annotations `finally` query conn ("DEALLOCATE " <> statementName) + where + warnings annotations = + conn.describePrepared statementName >>= \case + Nothing -> pure [] + Just described -> do + count <- described.nfields + params <- described.nparams + explained <- explain params + if fromIntegral count /= length annotations + then pure [] + else fmap concat . forM (zip [0 :: Int32 ..] annotations) $ \(i, annotation) -> do + table <- described.ftable i + tableColumn <- described.ftablecol i + name <- maybe "?column?" Text.decodeUtf8Lenient <$> described.fname i + let planned = case explained of + Just (outputs, nullability) + | Just out <- lookup i (zip [0 ..] outputs) -> + ( out `mentionedIn` nullability.outerJoined + , guardsApply && out `mentionedIn` nullability.filteredNotNull + ) + _ -> (False, False) + warn r = [Warning (fromIntegral i + 1) name r] + pure case (annotation, planned, Map.lookup (table, tableColumn) catalogue.columns) of + (Annotation{nullable = Just False}, (_, True), _) -> [] + (Annotation{nullable = Just False}, (True, _), _) -> warn "comes from the nullable side of an outer join" + (Annotation{nullable = Just False}, _, Just col) + | not col.fromView && not col.notNull -> warn (col.qualifiedName <> " is nullable") + _ -> [] + + -- A filter in the plan is about the rows read. Those are the rows a SELECT + -- returns, and those a DELETE returns, but an UPDATE returns the rows it + -- wrote, and an INSERT the rows it made. + guardsApply = case stmt of + Ast.SelectPreparableStmt _ -> True + Ast.DeletePreparableStmt _ -> True + _ -> False + + -- The top node's outputs, one per result column, and what the plan says + -- about them. Nothing if EXPLAIN fails. + explain params = do + let nulls = ByteString.Char8.intercalate ", " (replicate (fromIntegral params) "NULL") + args = if params == 0 then "" else ByteString.Char8.cons '(' (ByteString.Char8.snoc nulls ')') + result <- query conn ("EXPLAIN (VERBOSE, FORMAT JSON) EXECUTE " <> statementName <> args) + pure case result of + Right [[Just json]] + | Right [Explained plan] <- Aeson.eitherDecodeStrict json -> + Just (plan.output, planNullability plan) + _ -> Nothing + + +-- | Run a statement, returning its rows as text or the server's error. +query :: Pqi.Connection -> ByteString -> IO (Either String [[Maybe ByteString]]) +query conn sql = + conn.exec sql >>= \case + Nothing -> Left . maybe "no result" (Text.unpack . Text.decodeUtf8Lenient) <$> conn.errorMessage + Just result -> do + status <- result.resultStatus + rows <- + if status `elem` [Pqi.CommandOk, Pqi.TuplesOk] + then do + n <- result.ntuples + m <- result.nfields + Right <$> forM [0 .. n - 1] (forM [0 .. m - 1] . result.getvalue') + else Left . maybe "query failed" (Text.unpack . Text.decodeUtf8Lenient) <$> result.resultErrorMessage + result.unsafeFreeResult + pure rows diff --git a/src/Hasql/Check/Parser.y b/src/Hasql/Check/Parser.y new file mode 100644 --- /dev/null +++ b/src/Hasql/Check/Parser.y @@ -0,0 +1,60 @@ +{ +{-# LANGUAGE NoStrictData #-} + +module Hasql.Check.Parser where + +import Prelude +import Data.Text (Text) +import Hasql.Check.Lexer +import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Lazy as ByteString.Lazy +import System.Directory +} + +%expect 0 +%name parse +%monad { Alex } { >>= } { return } +%lexer { lexer } { Lexeme _ Eof } +%tokentype { Lexeme } +%error { parseError } + +%token + + quoter { Lexeme _ (Quoter _) } + quote { Lexeme _ (Quote _) } + +%% + +quasiquotes : quasiquotes quasiquote { $2 : $1 } + | {- empty -} { [] } + +quasiquote : quoter quote { mkQuasiQuote $1 $2 } + +{ + +type QuasiQuotes = [QuasiQuote] + +data QuasiQuote = + QuasiQuote (AlexPosn, Text) (AlexPosn, Text) + deriving (Eq, Show) + +mkQuasiQuote :: Lexeme -> Lexeme -> QuasiQuote +mkQuasiQuote (Lexeme posna (Quoter q)) + (Lexeme posnb (Quote qq)) + = QuasiQuote (posna, q) (posnb, qq) +mkQuasiQuote _ _ = error "mkQuasiQuote: Impossible" + +parseError :: Lexeme -> Alex a +parseError (Lexeme (AlexPn _ line col) lc) = alexError ("Parsing failed at line: " <> show line <> ", col: " <> show col <> " " <> show lc) + +-- | The quasiquotes in a Haskell source, in the order they appear. +parseQuasiQuotes :: ByteString -> Either String QuasiQuotes +parseQuasiQuotes s = reverse <$> runAlex s parse + +parseFile :: FilePath -> IO (Either String QuasiQuotes) +parseFile fn = do + flag <- doesFileExist fn + if not flag + then pure $ Left ("The following file does not exist : " ++ fn) + else parseQuasiQuotes <$> ByteString.Lazy.readFile fn +} diff --git a/src/Hasql/Check/Quoter.hs b/src/Hasql/Check/Quoter.hs new file mode 100644 --- /dev/null +++ b/src/Hasql/Check/Quoter.hs @@ -0,0 +1,39 @@ +-- | +-- Module : Hasql.Check.Quoter +-- Copyright : (c) 2022 Kronor.io +-- +-- License : BSD-3-Clause +-- Maintainer : lorenzo@kronor.io +-- Stability : experimental +-- Portability : GHC +module Hasql.Check.Quoter where + +import Data.Text (Text) +import Data.Text qualified as Text +import Prelude + + +-- | The hasql-th quoters whose SQL is a single preparable statement. +-- @uncheckedSql@ is deliberately absent: hasql-th neither parses nor prepares +-- it, because it is meant for scripts -- DDL, several statements -- that +-- PREPARE rejects. +quotersSupported :: [Text] +quotersSupported = + [ "singletonStatement" + , "maybeStatement" + , "vectorStatement" + , "foldStatement" + , "resultlessStatement" + , "rowsAffectedStatement" + ] + + +-- | The quoter's name without its module qualifier: @Hasql.TH.vectorStatement@ +-- becomes @vectorStatement@. +unqualified :: Text -> Text +unqualified = Text.takeWhileEnd (/= '.') + + +-- | Whether a quoter, qualified or not, is one of the given names. +isQuoterIn :: [Text] -> Text -> Bool +isQuoterIn names quoter = unqualified quoter `elem` names diff --git a/src/Hasql/Check/TH.hs b/src/Hasql/Check/TH.hs new file mode 100644 --- /dev/null +++ b/src/Hasql/Check/TH.hs @@ -0,0 +1,131 @@ +-- | +-- Module : Hasql.Check.TH +-- Copyright : (c) 2026 Kronor.io +-- +-- License : BSD-3-Clause +-- Maintainer : lorenzo@kronor.io +-- Stability : experimental +-- Portability : GHC +-- +-- hasql-th's quasiquoters, checking their statements against a live database +-- while they compile. Import this module instead of "Hasql.TH". +-- +-- Nothing is checked unless @HASQL_CHECK_DATABASE_URL@ is set, so builds +-- without a database - CI, nix - behave exactly as with "Hasql.TH". When it +-- is set, a statement that does not @PREPARE@ against that database is a +-- compile error at its quote. +-- +-- * @HASQL_CHECK_DATABASE_URL@: a libpq connection string or URI. +-- * @HASQL_CHECK_SCHEMA_FILE@: a file that changes whenever the schema does, +-- such as a migration plan. Every module with a checked quote depends on +-- it, so a schema change rechecks them. Cabal only notices it if it is also +-- listed in the package's @extra-source-files@; GHCi notices it regardless. +-- * @HASQL_CHECK_NULLABILITY@: when set, the warnings of @hasql-check +-- --nullability@ become compiler warnings. +-- * @HASQL_CHECK_TYPES@: when set, so do the warnings of @hasql-check +-- --types@. +-- +-- GHC runs a quote only when it compiles the module, so a module compiled +-- before the database was set, or before the schema changed, is not checked +-- until it recompiles. Run the @hasql-check@ executable in CI for a check +-- of everything. +module Hasql.Check.TH ( + -- * Statements + singletonStatement, + maybeStatement, + vectorStatement, + foldStatement, + resultlessStatement, + rowsAffectedStatement, + uncheckedSql, + uncheckedSqlFile, + + -- * Checking any quoter + checked, +) where + +import Control.Monad (forM_) +import Data.Text qualified as Text +import Hasql.Check (parseStmt, prepareStmt, renderStmt) +import Hasql.Check.Compile (Config (..), Session (..), readConfig, reportUnavailable, warning, warnings, withSession) +import Hasql.Check.Finding (Rule (..), statementHash) +import Hasql.Check.Nullability qualified as Nullability +import Hasql.Check.Types qualified as Types +import Hasql.TH (uncheckedSql, uncheckedSqlFile) +import Hasql.TH qualified as TH +import Language.Haskell.TH (Loc (..), Q, location, runIO) +import Language.Haskell.TH.Quote (QuasiQuoter (..)) +import Language.Haskell.TH.Syntax (addDependentFile) +import Prelude + + +singletonStatement :: QuasiQuoter +singletonStatement = withRows TH.singletonStatement + + +maybeStatement :: QuasiQuoter +maybeStatement = withRows TH.maybeStatement + + +vectorStatement :: QuasiQuoter +vectorStatement = withRows TH.vectorStatement + + +foldStatement :: QuasiQuoter +foldStatement = withRows TH.foldStatement + + +resultlessStatement :: QuasiQuoter +resultlessStatement = checked TH.resultlessStatement + + +rowsAffectedStatement :: QuasiQuoter +rowsAffectedStatement = checked TH.rowsAffectedStatement + + +-- | Check a quoter's statements, then run it. For quoters built on hasql-th's +-- statement syntax. +checked :: QuasiQuoter -> QuasiQuoter +checked = wrap False + + +-- | 'checked', also checking nullability when asked to. +withRows :: QuasiQuoter -> QuasiQuoter +withRows = wrap True + + +wrap :: Bool -> QuasiQuoter -> QuasiQuoter +wrap rows quoter = quoter{quoteExp = \sql -> check rows sql *> quoteExp quoter sql} + + +-- * Checking + + +check :: Bool -> String -> Q () +check rows sql = do + config <- runIO readConfig + forM_ config.schemaFile addDependentFile + forM_ config.databaseUrl \url -> case parseStmt (Text.pack sql) of + -- hasql-th reports the parse error itself. + Left _ -> pure () + Right stmt -> do + let rules = [Nullable | rows && config.nullability] <> [Narrowing | config.types] + outcome <- runIO $ withSession config url (not (null rules)) \s -> + prepareStmt s.connection "" stmt >>= \case + Left err -> pure (Left err) + Right () -> case s.catalogue of + Just (_, cat) | not (null rules) -> do + nullable <- if Nullable `elem` rules then Nullability.check s.connection cat stmt else pure [] + narrowing <- if Narrowing `elem` rules then Types.check s.connection cat stmt else pure [] + pure (Right (nullable <> narrowing)) + _ -> pure (Right []) + case outcome of + Left why -> runIO (reportUnavailable why) + Right (Left err) -> fail ("hasql-check: the statement does not prepare against HASQL_CHECK_DATABASE_URL:\n" <> err) + -- Without warnings asked for, no location is needed: there is + -- none outside GHC, under runQ. + Right (Right _) | null rules -> pure () + Right (Right found) -> do + loc <- location + messages <- runIO (warnings config rules loc.loc_filename (fst loc.loc_start) (statementHash (renderStmt stmt)) found) + forM_ messages (runIO . warning loc.loc_filename loc.loc_start) diff --git a/src/Hasql/Check/Types.hs b/src/Hasql/Check/Types.hs new file mode 100644 --- /dev/null +++ b/src/Hasql/Check/Types.hs @@ -0,0 +1,276 @@ +-- | +-- Module : Hasql.Check.Types +-- Copyright : (c) 2026 Kronor.io +-- +-- License : BSD-3-Clause +-- Maintainer : lorenzo@kronor.io +-- Stability : experimental +-- Portability : GHC +-- +-- Warn about annotations that convert a value to a narrower type. +-- +-- An annotation is a cast, and a cast between incompatible types is an error +-- @PREPARE@ already reports. A narrowing one is not: @bigint_column :: int4@ +-- prepares, and fails or loses data at runtime only for values that do not +-- fit. To see what each annotation converts, the statement is prepared again +-- without the annotations on its result columns and on the parameters it +-- assigns to columns - in @INSERT ... VALUES@ and @UPDATE ... SET@ - and +-- Postgres reports the types it finds there. +-- +-- Only result columns that read a table column are checked: an expression +-- converted to a narrower type - @count(*) :: int4@, @now() :: date@ - is +-- almost always converted on purpose. +-- +-- Parameters anywhere else are not checked: comparing an @int4@ column with an +-- @int8@ parameter widens the column, and narrows nothing. +module Hasql.Check.Types ( + check, + checkColumns, +) where + +import Control.Exception (finally) +import Control.Monad (forM) +import Data.ByteString.Char8 qualified as ByteString.Char8 +import Data.Functor ((<&>)) +import Data.Maybe (catMaybes, fromMaybe) +import Data.Text qualified as Text +import Data.Text.Encoding qualified as Text +import Data.Traversable (mapAccumL) +import Data.Word (Word32) +import Hasql.Check (renderStmt) +import Hasql.Check.Finding (Finding (..), Rule (..)) +import Hasql.Check.Nullability (Annotation (..), Catalogue, baseType, query, strip) +import PostgresqlSyntax qualified as Ast +import Pqi qualified +import Text.Read (readMaybe) +import Prelude + + +-- | The findings for a statement that prepares. +check :: Pqi.Connection -> Catalogue -> Ast.PreparableStmt -> IO [Finding] +check conn catalogue stmt + | null (fst (stripAssigned 0 stmt)) && maybe True (null . fst) (strip stmt) = pure [] + | otherwise = + ( describe "hasql_check_types_annotated" stmt Nothing >>= \case + Nothing -> pure [] + Just annotated -> do + -- Every assigned occurrence gets a placeholder of its own, so + -- that a parameter assigned to two columns is checked against + -- both; the statement's own parameters keep their annotated + -- types, declared, since some may now appear nowhere. + let (assigned, withoutParams) = stripAssigned (length annotated.params) stmt + (annotations, stripped) = fromMaybe ([], withoutParams) (strip withoutParams) + declared = annotated.params <> map (const 0) assigned + describe "hasql_check_types_stripped" stripped (Just declared) >>= \case + Nothing -> pure [] + Just found -> (<>) <$> results annotations annotated found <*> params assigned annotated found + ) + `finally` mapM_ (\name -> query conn ("DEALLOCATE " <> name)) ["hasql_check_types_annotated", "hasql_check_types_stripped"] + where + results annotations annotated found + | length annotations /= length annotated.columns || length found.columns /= length annotated.columns = pure [] + | otherwise = + fmap catMaybes . sequence $ + [ narrowing conn catalogue from to <&> fmap \(fromName, toName, consequence) -> + Finding Narrowing (Text.pack name) ("column " <> show i <> " (" <> name <> ") is annotated " <> toName <> ", but is " <> article fromName <> ": " <> consequence) + | (i, Annotation{nullable = Just _}, (name, to, _), (_, from, fromTable)) <- zip4 [1 :: Int ..] annotations annotated.columns found.columns + , fromTable + ] + + params assigned annotated found = + fmap catMaybes . sequence $ + [ narrowing conn catalogue from to <&> fmap \(fromName, toName, consequence) -> + Finding Narrowing (Text.pack ("$" <> show n)) ("parameter $" <> show n <> " is annotated " <> fromName <> ", but is assigned to " <> article toName <> " column: " <> consequence) + | (n, placeholder) <- assigned + , Just from <- [lookupParam n annotated] + , Just to <- [lookupParam placeholder found] + ] + + lookupParam n d = lookup n (zip [1 ..] d.params) + + describe name s types = do + prepared <- conn.prepare name (renderStmt s) types + status <- maybe (pure Pqi.FatalError) (.resultStatus) prepared + if status /= Pqi.CommandOk + then pure Nothing + else + conn.describePrepared name >>= \case + Nothing -> pure Nothing + Just d -> do + nparams <- d.nparams + nfields <- d.nfields + ps <- forM [0 .. nparams - 1] d.paramtype + cs <- forM [0 .. nfields - 1] \i -> + (,,) + <$> (maybe "?column?" (Text.unpack . Text.decodeUtf8Lenient) <$> d.fname i) + <*> d.ftype i + <*> ((/= 0) <$> d.ftable i) + pure (Just (Described ps cs)) + + +-- | The findings for result columns read as the given Postgres types, by +-- name, rather than annotated: those of an inferred statement, cast around +-- it. Every column is checked, expressions too: nobody chose the conversion. +checkColumns :: Pqi.Connection -> Catalogue -> [Text.Text] -> Ast.PreparableStmt -> IO [Finding] +checkColumns conn catalogue types stmt = do + prepared <- conn.prepare "hasql_check_types_columns" (renderStmt stmt) Nothing + status <- maybe (pure Pqi.FatalError) (.resultStatus) prepared + if status /= Pqi.CommandOk + then pure [] + else + ( conn.describePrepared "hasql_check_types_columns" >>= \case + Nothing -> pure [] + Just d -> do + n <- d.nfields + found <- forM [0 .. n - 1] \i -> (,) <$> (maybe "?column?" (Text.unpack . Text.decodeUtf8Lenient) <$> d.fname i) <*> d.ftype i + expected <- traverse oid types + fmap catMaybes . sequence $ + [ narrowing conn catalogue from to <&> fmap \(fromName, toName, consequence) -> + Finding Narrowing (Text.pack name) ("column " <> show i <> " (" <> name <> ") is annotated " <> toName <> ", but is " <> article fromName <> ": " <> consequence) + | length found == length types + , (i :: Int, (name, from), Just to) <- zip3 [1 ..] found expected + ] + ) + `finally` query conn "DEALLOCATE hasql_check_types_columns" + where + oid name = + query conn (mconcat ["SELECT to_regtype('", Text.encodeUtf8 (Text.replace "'" "''" name), "')::oid::text"]) >>= \case + Right [[Just o]] -> pure (readMaybe (ByteString.Char8.unpack o)) + _ -> pure Nothing + + +-- | 'lossy', through domains, and through arrays element by element, as +-- Postgres converts them: a bigint[] read as integer[] may overflow. +narrowing :: Pqi.Connection -> Catalogue -> Word32 -> Word32 -> IO (Maybe (String, String, String)) +narrowing conn catalogue from to = + query + conn + ( ByteString.Char8.pack + ( concat + [ "SELECT f.typelem::text, t.typelem::text FROM pg_catalog.pg_type f, pg_catalog.pg_type t WHERE f.oid = " + , show from' + , " AND t.oid = " + , show to' + , " AND f.typcategory = 'A' AND t.typcategory = 'A'" + ] + ) + ) + >>= \case + Right [[Just f, Just t]] + | Just f' <- readMaybe (ByteString.Char8.unpack f) + , Just t' <- readMaybe (ByteString.Char8.unpack t) -> + fmap (\(fromName, toName, consequence) -> (fromName <> "[]", toName <> "[]", consequence)) <$> narrowing conn catalogue f' t' + _ -> pure (lossy from' to') + where + from' = baseType catalogue from + to' = baseType catalogue to + + +data Described = Described + { params :: [Word32] + , columns :: [(String, Word32, Bool)] + -- ^ Name, type, and whether it is a table column rather than an expression. + } + + +zip4 :: [a] -> [b] -> [c] -> [d] -> [(a, b, c, d)] +zip4 (a : as) (b : bs) (c : cs) (d : ds) = (a, b, c, d) : zip4 as bs cs ds +zip4 _ _ _ _ = [] + + +article :: String -> String +article name@(c : _) | c `elem` ("aeiou" :: String) = "an " <> name +article name = "a " <> name + + +-- * Stripping assigned parameters + + +-- | The statement with each parameter it assigns to a column replaced by a +-- new, unannotated placeholder numbered from after the given count, and the +-- pairs of parameter and placeholder. +stripAssigned :: Int -> Ast.PreparableStmt -> ([(Int, Int)], Ast.PreparableStmt) +stripAssigned count = \case + Ast.InsertPreparableStmt + ( Ast.InsertStmt + w + t + (Ast.SelectInsertRest cols o (Ast.NoParensSelectStmt (Ast.SelectNoParens w2 (Ast.SimpleSelectSelectClause (Ast.ValuesSimpleSelect (Ast.ValuesClause rows))) s l f))) + c + r + ) -> + let (acc, rows') = mapAccumL (\a (Ast.ExprList es) -> Ast.ExprList <$> mapAccumL param a es) [] rows + in (reverse acc, Ast.InsertPreparableStmt (Ast.InsertStmt w t (Ast.SelectInsertRest cols o (Ast.NoParensSelectStmt (Ast.SelectNoParens w2 (Ast.SimpleSelectSelectClause (Ast.ValuesSimpleSelect (Ast.ValuesClause rows'))) s l f))) c r)) + Ast.UpdatePreparableStmt (Ast.UpdateStmt w rel (Ast.SetClauseList clauses) f wh r) -> + let (acc, clauses') = mapAccumL setClause [] clauses + in (reverse acc, Ast.UpdatePreparableStmt (Ast.UpdateStmt w rel (Ast.SetClauseList clauses') f wh r)) + other -> ([], other) + where + setClause acc = \case + Ast.TargetSetClause target e -> Ast.TargetSetClause target <$> param acc e + other -> (acc, other) + param acc = \case + Ast.TypecastAExpr (Ast.CExprAExpr (Ast.ParamCExpr n Nothing)) _ -> + let placeholder = count + length acc + 1 + in ((n, placeholder) : acc, Ast.CExprAExpr (Ast.ParamCExpr placeholder Nothing)) + e -> (acc, e) + + +-- * Narrowing conversions + + +-- | What converting a value of the first type to the second can do to it, with +-- the two types' names, if it is a narrowing conversion. +lossy :: Word32 -> Word32 -> Maybe (String, String, String) +lossy from to = do + fromName <- lookup from names + toName <- lookup to names + consequence <- lookup (from, to) conversions + pure (fromName, toName, consequence) + where + names = + [ (int2, "smallint") + , (int4, "integer") + , (int8, "bigint") + , (numeric, "numeric") + , (float4, "real") + , (float8, "double precision") + , (timestamp, "timestamp") + , (timestamptz, "timestamptz") + , (date, "date") + ] + overflow = "it may overflow" + rounding = "it may be rounded, or overflow" + precision = "it may lose precision" + conversions = + [ ((int8, int4), overflow) + , ((int8, int2), overflow) + , ((int4, int2), overflow) + , ((numeric, int8), rounding) + , ((numeric, int4), rounding) + , ((numeric, int2), rounding) + , ((float8, int8), rounding) + , ((float8, int4), rounding) + , ((float8, int2), rounding) + , ((float4, int8), rounding) + , ((float4, int4), rounding) + , ((float4, int2), rounding) + , ((numeric, float8), precision) + , ((numeric, float4), precision) + , ((float8, float4), precision) + , ((int8, float8), precision) + , ((int8, float4), precision) + , ((int4, float4), precision) + , ((timestamptz, timestamp), "it becomes a local time in the session's time zone") + , ((timestamptz, date), "it drops the time of day, in the session's time zone") + , ((timestamp, date), "it drops the time of day") + ] + int2 = 21 + int4 = 23 + int8 = 20 + numeric = 1700 + float4 = 700 + float8 = 701 + timestamp = 1114 + timestamptz = 1184 + date = 1082 diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,993 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE UndecidableInstances #-} + +module Main where + +import Control.Exception (SomeException, bracket_, try) +import Control.Monad (void) +import Data.ByteString.Lazy qualified as ByteString.Lazy +import Data.Either (isLeft) +import Data.Int (Int32, Int64) +import Data.List (isInfixOf) +import Data.Text (Text) +import Data.Text qualified as Text +import Data.Text.Encoding qualified as Text.Encoding +import Data.Vector qualified as Vector +import GHC.Generics (Generic) +import Hasql.Check.Inferred (Domain (..), PgEnum (..), Value, qualifiedName, render) +import Hasql.Check.Inferred.TH qualified as Inferred +import Hasql.Check.Lexer (AlexPosn (..)) +import Hasql.Check.Parser (QuasiQuote (..), parseQuasiQuotes) +import Hasql.Check.TH qualified as Checked +import Hasql.Connection qualified as Connection +import Hasql.Connection.Settings qualified as Settings +import Hasql.Session qualified as Session +import Hasql.Statement (Statement) +import Language.Haskell.TH (runQ) +import Language.Haskell.TH.Quote (QuasiQuoter (..)) +import Pqi.Ffi qualified +import System.Directory (createDirectoryIfMissing, findExecutable) +import System.Environment (getEnvironment, setEnv, unsetEnv) +import System.Exit (ExitCode (..)) +import System.FilePath (()) +import System.IO.Temp (withSystemTempDirectory) +import System.Process (callProcess, proc, readCreateProcessWithExitCode, readProcess) +import System.Process qualified as Process +import Test.Syd +import Prelude + + +main :: IO () +main = sydTest do + describe "parseQuasiQuotes" lexerSpec + describe "hasql-check" $ aroundAll withPostgres executableSpec + describe "hasql-check --nullability" $ aroundAll withPostgres nullabilitySpec + describe "hasql-check --types" $ aroundAll withPostgres typesSpec + describe "suppressing warnings" $ aroundAll withPostgres suppressionSpec + describe "Hasql.Check.Inferred.TH" piecesSpec + describe "inferred statements" $ aroundAll withPostgres runtimeSpec + describe "hasql-check --inferred" $ aroundAll withPostgres inferredSpec + -- These share the process's environment and the module's one connection, + -- so they run one at a time, in order. + describe "Hasql.Check.TH" $ sequential $ doNotRandomiseExecutionOrder $ aroundAll withPostgres thSpec + + +-- | The quoter, its line and column, and the SQL, of every quasiquote found. +quotes :: Text -> Either String [(Text, Int, Int, Text)] +quotes source = + map (\(QuasiQuote (AlexPn _ line col, quoter) (_, sql)) -> (quoter, line, col, sql)) + <$> parseQuasiQuotes (ByteString.Lazy.fromStrict (Text.Encoding.encodeUtf8 source)) + + +lexerSpec :: Spec +lexerSpec = do + it "finds a quote" $ + quotes "f = [singletonStatement|select 1 :: int4|]\n" + `shouldBe` Right [("singletonStatement", 1, 5, "select 1 :: int4")] + + it "finds a qualified quote" $ + quotes "f = [Hasql.TH.vectorStatement|select 1 :: int4|]\n" + `shouldBe` Right [("Hasql.TH.vectorStatement", 1, 5, "select 1 :: int4")] + + it "keeps the newlines inside a quote" $ + quotes "f =\n [resultlessStatement|\n delete from t\n |]\n" + `shouldBe` Right [("resultlessStatement", 2, 3, "\n delete from t\n ")] + + it "skips a quote in a line comment" $ + quotes "-- f = [singletonStatement|select 1 :: int4|]\n" + `shouldBe` Right [] + + it "skips a quote in a nested block comment" $ + quotes "{- {- -} [singletonStatement|select 1 :: int4|] -}\n" + `shouldBe` Right [] + + it "does not read an operator made of dashes as a comment" $ + quotes "a --> b = [singletonStatement|select 1 :: int4|]\n" + `shouldBe` Right [("singletonStatement", 1, 11, "select 1 :: int4")] + + it "does not open a comment from \"{-\" in a string" $ + quotes "s = \"{-\"\nf = [singletonStatement|select 1 :: int4|]\n" + `shouldBe` Right [("singletonStatement", 2, 5, "select 1 :: int4")] + + it "does not open a quote from \"[x|\" in a string" $ + quotes "s = \"[x|\"\nf = [singletonStatement|select 1 :: int4|]\n" + `shouldBe` Right [("singletonStatement", 2, 5, "select 1 :: int4")] + + it "does not open a string from a double quote character literal" $ + quotes "c = '\"'\nf = [singletonStatement|select 1 :: int4|]\n" + `shouldBe` Right [("singletonStatement", 2, 5, "select 1 :: int4")] + + it "does not open a character literal from a primed identifier" $ + quotes "g x' y' = \"{-\"\nf = [singletonStatement|select 1 :: int4|]\n" + `shouldBe` Right [("singletonStatement", 2, 5, "select 1 :: int4")] + + it "skips escaped quotes and gaps in a string" $ + quotes "s = \"a\\\"{-\\\n \\b\"\nf = [singletonStatement|select 1 :: int4|]\n" + `shouldBe` Right [("singletonStatement", 3, 5, "select 1 :: int4")] + + it "skips a multiline string" $ + quotes "s = \"\"\"\n say \"hi\" {-\n \"\"\"\nf = [singletonStatement|select 1 :: int4|]\n" + `shouldBe` Right [("singletonStatement", 4, 5, "select 1 :: int4")] + + it "rejects a quote left open" $ + quotes "f = [singletonStatement|select 1 :: int4\n" + `shouldSatisfy` either ("not closed" `isInfixOf`) (const False) + + +-- | A connection string for a throwaway server, reachable only over a socket +-- in a temporary directory. +withPostgres :: (Text -> IO ()) -> IO () +withPostgres action = + withSystemTempDirectory "hasql-check" \dir -> do + initdb <- findExecutable "initdb" + case initdb of + Nothing -> expectationFailure "initdb is not on PATH; the executable tests need a PostgreSQL installation" + Just _ -> pure () + let dataDir = dir "data" + conn = Text.pack ("host=" <> dir <> " port=5432 user=postgres dbname=postgres") + _ <- readProcess "initdb" ["--pgdata", dataDir, "--username", "postgres", "--auth", "trust", "--no-sync"] "" + bracket_ + (callProcess "pg_ctl" ["--pgdata", dataDir, "--log", dir "postgres.log", "--options", "-k " <> dir <> " -c listen_addresses=''", "--wait", "--silent", "start"]) + (callProcess "pg_ctl" ["--pgdata", dataDir, "--mode", "immediate", "--silent", "stop"]) + do + callProcess "psql" [Text.unpack conn, "--quiet", "--command", "create table account (id int4 primary key, name text not null, nickname text); create index on account (nickname); create table note (account_id int4 not null references account, body text not null); create domain cents as int8; create domain positive_cents as cents check (value > 0); create table wallet (balance positive_cents not null); create table ledger (id int8 primary key, small int2, amount int8 not null, rate float8, at timestamptz, price cents); create table tag (id int4 primary key, label varchar(20) not null); insert into tag values (1, 'red'); create table tagged (id int4 primary key, labels text[] not null, scores int4[]); insert into tagged values (1, '{a,b}', '{1,NULL,3}'); create table totals (id int4 primary key, amounts int8[] not null); create type payment_state as enum ('PENDING', 'PAID', 'REFUNDED'); create table payment (id int4 primary key, state payment_state not null); insert into payment values (1, 'PAID'); create domain payment_status as payment_state; create table payment_log (id int4 primary key, status payment_status not null); insert into payment_log values (1, 'REFUNDED')"] + action conn + + +-- | Run the executable on a source file and the given flags, with extra +-- environment variables; return the exit code and stdout. +runOn :: [(String, String)] -> [String] -> Text -> IO (ExitCode, String) +runOn env args source = + withSystemTempDirectory "hasql-check-src" \dir -> do + let file = dir "Fixture.hs" + ByteString.Lazy.writeFile file (ByteString.Lazy.fromStrict (Text.Encoding.encodeUtf8 source)) + inherited <- getEnvironment + let unset = ["DATABASE_URL", "psql_conn_string"] + procEnv = env <> filter ((`notElem` (unset <> map fst env)) . fst) inherited + (code, out, err) <- + readCreateProcessWithExitCode + (proc "hasql-check" (args <> [file])){Process.env = Just procEnv} + "" + pure (code, out <> err) + + +executableSpec :: TestDef '[Text] () +executableSpec = do + itWithOuter "accepts a statement that matches the schema" \conn -> do + (code, out) <- runOn [] ["--database", Text.unpack conn] "f = [singletonStatement|select name :: text from account where id = $1 :: int4|]\n" + (code, out) `shouldBe` (ExitSuccess, "") + + itWithOuter "rejects a statement that does not, and says where it is" \conn -> do + (code, out) <- runOn [] ["--database", Text.unpack conn] "f = 1\ng = [singletonStatement|select nope :: text from account|]\n" + code `shouldBe` ExitFailure 1 + out `shouldSatisfy` ("Fixture.hs:2:5" `isInfixOf`) + out `shouldSatisfy` ("column \"nope\" does not exist" `isInfixOf`) + + itWithOuter "accepts nullability markers" \conn -> do + (code, out) <- runOn [] ["--database", Text.unpack conn] "f = [maybeStatement|select name :: text? from account where id = $1 :: int4?|]\n" + (code, out) `shouldBe` (ExitSuccess, "") + + syntaxSpec + + itWithOuter "checks a qualified quote" \conn -> do + (code, out) <- runOn [] ["--database", Text.unpack conn] "f = [Hasql.TH.resultlessStatement|delete from nowhere|]\n" + code `shouldBe` ExitFailure 1 + out `shouldSatisfy` ("relation \"nowhere\" does not exist" `isInfixOf`) + + itWithOuter "leaves uncheckedSql alone" \conn -> do + (code, out) <- runOn [] ["--database", Text.unpack conn] "f = [uncheckedSql|create table t (); create table u ();|]\n" + (code, out) `shouldBe` (ExitSuccess, "") + + itWithOuter "checks only the extra quoters it is given" \conn -> do + let source = "f = [myStatement|select nope :: text from account|]\n" + (codeWithout, _) <- runOn [] ["--database", Text.unpack conn] source + codeWithout `shouldBe` ExitSuccess + (codeWith, out) <- runOn [] ["--database", Text.unpack conn, "--quoter", "myStatement"] source + codeWith `shouldBe` ExitFailure 1 + out `shouldSatisfy` ("column \"nope\" does not exist" `isInfixOf`) + + itWithOuter "connects through DATABASE_URL" \conn -> do + (code, out) <- runOn [("DATABASE_URL", Text.unpack conn)] [] "f = [singletonStatement|select nope :: text from account|]\n" + code `shouldBe` ExitFailure 1 + out `shouldSatisfy` ("column \"nope\" does not exist" `isInfixOf`) + + it "lists the quotes it would check without connecting" do + (code, out) <- + runOn + [("DATABASE_URL", "host=/nonexistent")] + ["--list"] + "f = [singletonStatement|select 1 :: int4|]\ng = [Hasql.TH.vectorStatement|select 1 :: int4|]\nh = [aesonQQ|{}|]\n" + code `shouldBe` ExitSuccess + lines out `shouldSatisfy` \case + [first, second] -> + "Fixture.hs:1:5: singletonStatement" `isSuffixOfStr` first + && "Fixture.hs:2:5: Hasql.TH.vectorStatement" `isSuffixOfStr` second + _ -> False + where + isSuffixOfStr suffix s = Text.pack suffix `Text.isSuffixOf` Text.pack s + + +-- | The syntax only Kronor's fork of hasql-th accepts. +syntaxSpec :: TestDef '[Text] () +#ifdef KRONOR_SYNTAX +syntaxSpec = do + itWithOuter "accepts Haskell targets and param fields" \conn -> do + (code, out) <- runOn [] ["--database", Text.unpack conn] "f = [maybeStatement|select $Just (name :: text) from account where id = $1.$accountId :: int4|]\n" + (code, out) `shouldBe` (ExitSuccess, "") + + itWithOuter "checks the columns inside a Haskell target" \conn -> do + (code, out) <- runOn [] ["--database", Text.unpack conn] "f = [maybeStatement|select $Just (nope :: text) from account|]\n" + code `shouldBe` ExitFailure 1 + out `shouldSatisfy` ("column \"nope\" does not exist" `isInfixOf`) +#else +syntaxSpec = + itWithOuter "rejects Haskell targets, which upstream hasql-th does not accept" \conn -> do + (code, out) <- runOn [] ["--database", Text.unpack conn] "f = [maybeStatement|select $Just (name :: text) from account|]\n" + code `shouldBe` ExitFailure 1 + out `shouldSatisfy` ("Fixture.hs:1:5" `isInfixOf`) +#endif + + +-- | Run with --nullability on one statement; return the exit code and output. +nullability :: Text -> Text -> IO (ExitCode, String) +nullability conn statement = + runOn [] ["--database", Text.unpack conn, "--nullability"] ("f = [vectorStatement|" <> statement <> "|]\n") + + +nullabilitySpec :: TestDef '[Text] () +nullabilitySpec = do + itWithOuter "warns about a nullable column annotated non-null, without failing" \conn -> do + (code, out) <- nullability conn "select nickname :: text from account" + code `shouldBe` ExitSuccess + out `shouldSatisfy` ("Fixture.hs:1:5" `isInfixOf`) + out `shouldSatisfy` ("column 1 (nickname) is annotated non-null, but public.account.nickname is nullable" `isInfixOf`) + + itWithOuter "warns only when asked" \conn -> do + (code, out) <- runOn [] ["--database", Text.unpack conn] "f = [vectorStatement|select nickname :: text from account|]\n" + (code, out) `shouldBe` (ExitSuccess, "") + + itWithOuter "accepts a nullable column annotated nullable" \conn -> + nullability conn "select nickname :: text? from account" `shouldReturn` (ExitSuccess, "") + + itWithOuter "accepts a NOT NULL column annotated non-null" \conn -> + nullability conn "select name :: text, id :: int4 from account" `shouldReturn` (ExitSuccess, "") + + itWithOuter "accepts a column guarded by IS NOT NULL" \conn -> + nullability conn "select nickname :: text from account where id > 0 and nickname is not null" `shouldReturn` (ExitSuccess, "") + + itWithOuter "accepts a guard that leaves out the table" \conn -> + nullability conn "select a.nickname :: text from account a where nickname is not null" `shouldReturn` (ExitSuccess, "") + + itWithOuter "does not check expressions" \conn -> + nullability conn "select count(*) :: int8, max(nickname) :: text from account" `shouldReturn` (ExitSuccess, "") + + itWithOuter "warns about a NOT NULL column on the nullable side of a left join" \conn -> do + (code, out) <- nullability conn "select a.name :: text, n.body :: text from account a left join note n on n.account_id = a.id" + code `shouldBe` ExitSuccess + out `shouldSatisfy` ("column 2 (body) is annotated non-null, but comes from the nullable side of an outer join" `isInfixOf`) + out `shouldNotSatisfy` ("column 1" `isInfixOf`) + + -- Postgres plans the joins above as right joins with the tables swapped; + -- a lateral join cannot be swapped, so this one is planned as a left join. + itWithOuter "warns about the nullable side of a join planned as a left join" \conn -> do + (_, out) <- nullability conn "select a.name :: text, n.body :: text from account a left join lateral (select body from note where note.account_id = a.id limit 1) n on true" + out `shouldSatisfy` ("column 2 (body)" `isInfixOf`) + out `shouldNotSatisfy` ("column 1" `isInfixOf`) + + itWithOuter "warns about the nullable side of a right join only" \conn -> do + (_, out) <- nullability conn "select a.name :: text, n.body :: text from note n right join account a on n.account_id = a.id" + out `shouldSatisfy` ("column 2 (body)" `isInfixOf`) + out `shouldNotSatisfy` ("column 1" `isInfixOf`) + + itWithOuter "warns about both sides of a full join" \conn -> do + (_, out) <- nullability conn "select a.name :: text, n.body :: text from account a full join note n on n.account_id = a.id" + out `shouldSatisfy` ("column 1 (name)" `isInfixOf`) + out `shouldSatisfy` ("column 2 (body)" `isInfixOf`) + + itWithOuter "lets IS NOT NULL clear the nullable side of a join" \conn -> + nullability conn "select n.body :: text from account a left join note n on n.account_id = a.id where n.body is not null" `shouldReturn` (ExitSuccess, "") + + itWithOuter "does not let an UPDATE's filter on the old row clear RETURNING's new one" \conn -> do + (_, out) <- nullability conn "update account set nickname = NULL where nickname is not null returning nickname :: text" + out `shouldSatisfy` ("public.account.nickname is nullable" `isInfixOf`) + + itWithOuter "lets a DELETE's filter clear RETURNING, which returns the rows it read" \conn -> + nullability conn "delete from account where nickname is not null returning nickname :: text" `shouldReturn` (ExitSuccess, "") + + -- With sequential scans off, Postgres answers the OR with a BitmapOr of + -- two index scans, one of which has the IS NOT NULL as its condition. + itWithOuter "does not take one branch of a BitmapOr for a guarantee" \conn -> do + (_, out) <- + runOn + [("PGOPTIONS", "-c enable_seqscan=off")] + ["--database", Text.unpack conn, "--nullability"] + "f = [vectorStatement|select nickname :: text from account where nickname is not null or id = $1 :: int4|]\n" + out `shouldSatisfy` ("public.account.nickname is nullable" `isInfixOf`) + + itWithOuter "checks a statement with parameters" \conn -> do + (_, out) <- nullability conn "select nickname :: text from account where id = $1 :: int4" + out `shouldSatisfy` ("public.account.nickname is nullable" `isInfixOf`) + + itWithOuter "checks RETURNING" \conn -> do + (_, out) <- nullability conn "update account set name = name returning nickname :: text, name :: text" + out `shouldSatisfy` ("column 1 (nickname)" `isInfixOf`) + out `shouldNotSatisfy` ("column 2" `isInfixOf`) + + +-- | Run a checked quoter as a splice would. Outside GHC a failing splice only +-- says that it failed - the message goes to stderr - so the tests that expect +-- a failure pair it with the same statement passing when nothing is checked. +quote :: QuasiQuoter -> String -> IO (Either String ()) +quote quoter sql = either (Left . show) (const (Right ())) <$> (try (void (runQ (quoteExp quoter sql))) :: IO (Either SomeException ())) + + +thSpec :: TestDef '[Text] () +thSpec = do + it "checks nothing when no database is set" do + unsetEnv "HASQL_CHECK_DATABASE_URL" + quote Checked.vectorStatement "select nope :: text from account" `shouldReturn` Right () + quote Checked.resultlessStatement "delete from nowhere" `shouldReturn` Right () + + it "does not fail the build when the database cannot be reached" do + setEnv "HASQL_CHECK_DATABASE_URL" "host=/nonexistent" + quote Checked.maybeStatement "select nope :: text from account" `shouldReturn` Right () + + itWithOuter "accepts a statement that prepares" \conn -> do + setEnv "HASQL_CHECK_DATABASE_URL" (Text.unpack conn) + quote Checked.maybeStatement "select name :: text from account where id = $1 :: int4" `shouldReturn` Right () + + itWithOuter "fails on a statement that does not" \conn -> do + setEnv "HASQL_CHECK_DATABASE_URL" (Text.unpack conn) + result <- quote Checked.vectorStatement "select nope :: text from account" + result `shouldSatisfy` isLeft + + itWithOuter "checks statements without rows" \conn -> do + setEnv "HASQL_CHECK_DATABASE_URL" (Text.unpack conn) + result <- quote Checked.resultlessStatement "delete from nowhere" + result `shouldSatisfy` isLeft + + -- Run after the tests above have left a connection open to the test + -- database: a broken statement fails there, but not when the database + -- named cannot be reached. + it "follows a change of database" do + setEnv "HASQL_CHECK_DATABASE_URL" "host=/nonexistent" + quote Checked.vectorStatement "select nope :: text from account" `shouldReturn` Right () + + +-- | Run with --types on one quote; return the exit code and output. +types :: Text -> Text -> Text -> IO (ExitCode, String) +types conn quoter statement = + runOn [] ["--database", Text.unpack conn, "--types"] ("f = [" <> quoter <> "|" <> statement <> "|]\n") + + +typesSpec :: TestDef '[Text] () +typesSpec = do + itWithOuter "warns about a column read as a narrower type, without failing" \conn -> do + (code, out) <- types conn "vectorStatement" "select amount :: int4 from ledger" + code `shouldBe` ExitSuccess + out `shouldSatisfy` ("column 1 (amount) is annotated integer, but is a bigint: it may overflow" `isInfixOf`) + + itWithOuter "warns about an array read as one of narrower elements" \conn -> do + (_, out) <- types conn "vectorStatement" "select amounts :: int4[] from totals" + out `shouldSatisfy` ("column 1 (amounts) is annotated integer[], but is a bigint[]: it may overflow" `isInfixOf`) + + itWithOuter "warns about an array parameter assigned to a column of narrower elements" \conn -> do + (_, out) <- types conn "resultlessStatement" "update tagged set scores = $1 :: int8[]" + out `shouldSatisfy` ("parameter $1 is annotated bigint[], but is assigned to an integer[] column: it may overflow" `isInfixOf`) + + itWithOuter "warns only when asked" \conn -> + runOn [] ["--database", Text.unpack conn] "f = [vectorStatement|select amount :: int4 from ledger|]\n" `shouldReturn` (ExitSuccess, "") + + itWithOuter "accepts a column read as its own type, or a wider one" \conn -> + types conn "vectorStatement" "select amount :: int8, small :: int4, id :: numeric from ledger" `shouldReturn` (ExitSuccess, "") + + itWithOuter "does not check expressions" \conn -> + types conn "vectorStatement" "select count(*) :: int4, now() :: date from ledger" `shouldReturn` (ExitSuccess, "") + + itWithOuter "warns about lost precision" \conn -> do + (_, out) <- types conn "vectorStatement" "select rate :: float4 from ledger" + out `shouldSatisfy` ("is annotated real, but is a double precision: it may lose precision" `isInfixOf`) + + itWithOuter "warns about a dropped time of day" \conn -> do + (_, out) <- types conn "vectorStatement" "select at :: date from ledger" + out `shouldSatisfy` ("is annotated date, but is a timestamptz" `isInfixOf`) + + itWithOuter "looks through domains" \conn -> do + (_, out) <- types conn "vectorStatement" "select price :: int4 from ledger" + out `shouldSatisfy` ("column 1 (price) is annotated integer, but is a bigint" `isInfixOf`) + + -- Postgres reports a result column of a domain type as the base type, but + -- a parameter assigned to one as the domain. + itWithOuter "looks through a domain a parameter is assigned to" \conn -> do + (_, out) <- types conn "resultlessStatement" "insert into ledger (id, amount, price) values ($1 :: int8, $2 :: int8, $3 :: numeric)" + out `shouldSatisfy` ("parameter $3 is annotated numeric, but is assigned to a bigint column: it may be rounded, or overflow" `isInfixOf`) + + itWithOuter "warns about a parameter inserted into a narrower column" \conn -> do + (_, out) <- types conn "resultlessStatement" "insert into account (id, name) values ($1 :: int8, $2 :: text)" + out `shouldSatisfy` ("parameter $1 is annotated bigint, but is assigned to an integer column: it may overflow" `isInfixOf`) + out `shouldNotSatisfy` ("parameter $2" `isInfixOf`) + + itWithOuter "accepts a parameter inserted into a column of its type" \conn -> + types conn "resultlessStatement" "insert into account (id, name) values ($1 :: int4, $2 :: text)" `shouldReturn` (ExitSuccess, "") + + itWithOuter "checks parameters set by UPDATE, not those compared" \conn -> do + (_, out) <- types conn "resultlessStatement" "update ledger set small = $1 :: int4 where amount = $2 :: int4" + out `shouldSatisfy` ("parameter $1 is annotated integer, but is assigned to a smallint column" `isInfixOf`) + out `shouldNotSatisfy` ("parameter $2" `isInfixOf`) + + itWithOuter "checks every column a parameter is assigned to" \conn -> do + (_, out) <- types conn "resultlessStatement" "update ledger set amount = $1 :: int8, small = $1 :: int8 where id = $2 :: int8" + out `shouldSatisfy` ("parameter $1 is annotated bigint, but is assigned to a smallint column" `isInfixOf`) + + itWithOuter "removes an annotation from ORDER BY too, so DISTINCT still prepares" \conn -> do + (_, out) <- types conn "vectorStatement" "select distinct amount :: int4 from ledger order by amount :: int4" + out `shouldSatisfy` ("column 1 (amount) is annotated integer, but is a bigint" `isInfixOf`) + + itWithOuter "removes an annotation from GROUP BY too" \conn -> do + (_, out) <- types conn "vectorStatement" "select amount :: int4 from ledger group by amount :: int4" + out `shouldSatisfy` ("column 1 (amount) is annotated integer, but is a bigint" `isInfixOf`) + + itWithOuter "checks RETURNING along with the assignments" \conn -> do + (_, out) <- types conn "singletonStatement" "insert into account (id, name) values ($1 :: int8, $2 :: text) returning id :: int2" + out `shouldSatisfy` ("column 1 (id) is annotated smallint, but is an integer" `isInfixOf`) + out `shouldSatisfy` ("parameter $1" `isInfixOf`) + + +-- | Run on a whole source with the given flags; return the exit code and output. +checkSource :: Text -> [String] -> Text -> IO (ExitCode, String) +checkSource conn flags = runOn [] (["--database", Text.unpack conn] <> flags) + + +suppressionSpec :: TestDef '[Text] () +suppressionSpec = do + itWithOuter "a directive above the quote suppresses the finding it names" \conn -> + checkSource conn ["--nullability"] "-- hasql-check: allow nullable(nickname)\nf = [vectorStatement|select nickname :: text from account|]\n" + `shouldReturn` (ExitSuccess, "") + + itWithOuter "a directive suppresses only what it names, and says what it did not use" \conn -> do + (_, out) <- checkSource conn ["--nullability"] "-- hasql-check: allow nullable(name)\nf = [vectorStatement|select nickname :: text from account|]\n" + out `shouldSatisfy` ("column 1 (nickname) is annotated non-null" `isInfixOf`) + out `shouldSatisfy` ("allow nullable(name) suppresses nothing" `isInfixOf`) + + itWithOuter "a directive applies only directly above the quote" \conn -> do + (_, out) <- checkSource conn ["--nullability"] "-- hasql-check: allow nullable(nickname)\n\nf = [vectorStatement|select nickname :: text from account|]\n" + out `shouldSatisfy` ("column 1 (nickname) is annotated non-null" `isInfixOf`) + + itWithOuter "directives read every comment line directly above" \conn -> + checkSource + conn + ["--nullability", "--types"] + "f =\n -- hasql-check: allow narrowing(amount)\n -- Why: the amounts here are small.\n -- hasql-check: allow nullable(nickname)\n [vectorStatement|select nickname :: text, amount :: int4 from account, ledger|]\n" + `shouldReturn` (ExitSuccess, "") + + itWithOuter "a directive names parameters as $n" \conn -> + checkSource conn ["--types"] "-- hasql-check: allow narrowing($1)\nf = [resultlessStatement|insert into account (id, name) values ($1 :: int8, $2 :: text)|]\n" + `shouldReturn` (ExitSuccess, "") + + itWithOuter "a directive for a rule that was not checked is not reported" \conn -> + checkSource conn ["--nullability"] "-- hasql-check: allow narrowing(amount)\nf = [vectorStatement|select name :: text from account|]\n" + `shouldReturn` (ExitSuccess, "") + + itWithOuter "a malformed directive is reported" \conn -> do + (_, out) <- checkSource conn ["--nullability"] "-- hasql-check: permit nullable(nickname)\nf = [vectorStatement|select name :: text from account|]\n" + out `shouldSatisfy` ("directive not understood: permit nullable(nickname)" `isInfixOf`) + + itWithOuter "--fail-on-warnings fails on a finding, not on a suppressed one" \conn -> do + (code, _) <- checkSource conn ["--nullability", "--fail-on-warnings"] "f = [vectorStatement|select nickname :: text from account|]\n" + code `shouldBe` ExitFailure 1 + (suppressed, _) <- checkSource conn ["--nullability", "--fail-on-warnings"] "-- hasql-check: allow nullable(nickname)\nf = [vectorStatement|select nickname :: text from account|]\n" + suppressed `shouldBe` ExitSuccess + + itWithOuter "a baseline ignores the findings it was written with, wherever the quote is" \conn -> + withSystemTempDirectory "hasql-check-baseline" \dir -> do + let baseline = dir "baseline" + flags = ["--nullability", "--fail-on-warnings"] + (written, _) <- checkSource conn (flags <> ["--write-baseline", baseline]) "f = [vectorStatement|select nickname :: text from account|]\n" + written `shouldBe` ExitFailure 1 + contents <- readFile baseline + contents `shouldSatisfy` (" nullable nickname # " `isInfixOf`) + -- The same statement, laid out differently and somewhere else. + checkSource conn (flags <> ["--baseline", baseline]) "g = 1\nf =\n [vectorStatement|\n select nickname :: text\n from account\n |]\n" + `shouldReturn` (ExitSuccess, "") + (changed, out) <- checkSource conn (flags <> ["--baseline", baseline]) "f = [vectorStatement|select nickname :: text from account where id > 0|]\n" + changed `shouldBe` ExitFailure 1 + out `shouldSatisfy` ("column 1 (nickname)" `isInfixOf`) + + itWithOuter "--files0-from checks every listed file in one run, so the baseline has them all" \conn -> + withSystemTempDirectory "hasql-check-files" \dir -> do + let a = dir "A.hs" + b = dir "B's.hs" + list = dir "files" + baseline = dir "baseline" + writeFile a "f = [vectorStatement|select nickname :: text from account|]\n" + writeFile b "g = [vectorStatement|select amount :: int4 from ledger|]\n" + writeFile list (a <> "\0" <> b <> "\0") + (code, _, _) <- + readCreateProcessWithExitCode + (proc "hasql-check" ["--database", Text.unpack conn, "--nullability", "--types", "--files0-from", list, "--write-baseline", baseline]) + "" + code `shouldBe` ExitSuccess + contents <- readFile baseline + contents `shouldSatisfy` (" nullable nickname # " `isInfixOf`) + contents `shouldSatisfy` (" narrowing amount # " `isInfixOf`) + + itWithOuter "a baseline and a directive handle a quoted column name" \conn -> + withSystemTempDirectory "hasql-check-quoted" \dir -> do + let baseline = dir "baseline" + source = "f = [vectorStatement|select nickname :: text as \"display name\" from account|]\n" + _ <- checkSource conn ["--nullability", "--write-baseline", baseline] source + contents <- readFile baseline + contents `shouldSatisfy` (" nullable \"display name\" # " `isInfixOf`) + checkSource conn ["--nullability", "--fail-on-warnings", "--baseline", baseline] source `shouldReturn` (ExitSuccess, "") + checkSource conn ["--nullability", "--fail-on-warnings"] ("-- hasql-check: allow nullable(\"display name\")\n" <> source) + `shouldReturn` (ExitSuccess, "") + + +-- | The SQL the inferred quoters send for a statement, given the Postgres +-- types of its parameters and result columns. +sent :: Text -> [Text] -> [Text] -> Either String Text +sent sql paramTypes columnTypes = render paramTypes columnTypes <$> Inferred.template sql + + +piecesSpec :: Spec +piecesSpec = do + it "annotates each parameter, and casts each result column around the statement" $ + sent "select email, nickname from customer where id = $1" ["int8"] ["text", "text"] + `shouldBe` Right "WITH hasql_check_result (c1, c2) AS (SELECT email, nickname FROM customer WHERE id = $1 :: int8) SELECT c1 :: text, c2 :: text FROM hasql_check_result" + + it "annotates every occurrence of a parameter" $ + sent "select a from t where b = $1 or c = $1" ["int4"] ["text"] + `shouldBe` Right "WITH hasql_check_result (c1) AS (SELECT a FROM t WHERE b = $1 :: int4 OR c = $1 :: int4) SELECT c1 :: text FROM hasql_check_result" + + it "casts RETURNING" $ + sent "update t set a = $1 returning id" ["text"] ["int8"] + `shouldBe` Right "WITH hasql_check_result (c1) AS (UPDATE t SET a = $1 :: text RETURNING id) SELECT c1 :: int8 FROM hasql_check_result" + + it "casts the columns behind a *" $ + sent "select * from t where id = $1" ["int8"] ["int8", "text"] + `shouldBe` Right "WITH hasql_check_result (c1, c2) AS (SELECT * FROM t WHERE id = $1 :: int8) SELECT c1 :: int8, c2 :: text FROM hasql_check_result" + + it "leaves the statement itself as it is: its DISTINCT ON, ORDER BY and GROUP BY" $ + sent "select distinct on (t.id) t.id from t group by 1 order by id" [] ["int8"] + `shouldBe` Right "WITH hasql_check_result (c1) AS (SELECT DISTINCT ON (t.id) t.id FROM t GROUP BY 1 ORDER BY id) SELECT c1 :: int8 FROM hasql_check_result" + + it "keeps the statement's own WITH list first, where a data-modifying one must be" $ + sent "with x as (update t set a = $1 returning a) select a from x" ["int8"] ["int8"] + `shouldBe` Right "WITH x AS (UPDATE t SET a = $1 :: int8 RETURNING a), hasql_check_result (c1) AS (SELECT a FROM x) SELECT c1 :: int8 FROM hasql_check_result" + + it "keeps a parenthesised statement's WITH list first too" $ + sent "(with x as (update t set a = 1 returning a) select a from x)" [] ["int8"] + `shouldBe` Right "WITH x AS (UPDATE t SET a = 1 RETURNING a), hasql_check_result (c1) AS ((SELECT a FROM x)) SELECT c1 :: int8 FROM hasql_check_result" + + it "picks a name the statement does not use" $ + sent "select a from hasql_check_result" [] ["int8"] + `shouldBe` Right "WITH hasql_check_result_ (c1) AS (SELECT a FROM hasql_check_result) SELECT c1 :: int8 FROM hasql_check_result_" + + it "keeps text in a literal that looks like an annotation" $ + sent "select ' :: hasql_check_slot_1'" [] ["text"] + `shouldBe` Right "WITH hasql_check_result (c1) AS (SELECT ' :: hasql_check_slot_1') SELECT c1 :: text FROM hasql_check_result" + + it "annotates an array parameter" $ + sent "select a from t where id = any($1)" ["int8[]"] ["text"] + `shouldBe` Right "WITH hasql_check_result (c1) AS (SELECT a FROM t WHERE id = ANY ($1 :: int8[])) SELECT c1 :: text FROM hasql_check_result" + + it "annotates a subscripted parameter before its subscript" $ + sent "select $1['a']" ["jsonb"] ["jsonb"] + `shouldBe` Right "WITH hasql_check_result (c1) AS (SELECT ($1 :: jsonb)['a']) SELECT c1 :: jsonb FROM hasql_check_result" + + it "sends a statement without rows as it is" $ + sent "delete from t where id = $1" ["int8"] [] + `shouldBe` Right "DELETE FROM t WHERE id = $1 :: int8" + + it "takes an enum's name as SQL, as a cast does, for the codecs" $ + map + qualifiedName + ["payment_state", "Public.Payment_State", "\"payment_state\"", "\"My Schema\".\"x.y\"", "app.public.payment_state"] + `shouldBe` [(Nothing, "payment_state"), (Just "public", "payment_state"), (Nothing, "payment_state"), (Just "My Schema", "x.y"), (Just "public", "payment_state")] + + it "rejects SQL it cannot parse" $ + Inferred.template "select from where" `shouldSatisfy` isLeft + + +data PaymentState = PENDING | PAID | REFUNDED + deriving stock (Eq, Show, Generic) + deriving (Value) via PgEnum "payment_state" PaymentState + + +newtype Qualified = Qualified PaymentState + deriving stock (Eq, Show) + deriving (Value) via PgEnum "public.\"payment_state\"" PaymentState + + +-- The test database is "postgres". +newtype InDatabase = InDatabase PaymentState + deriving stock (Eq, Show) + deriving (Value) via PgEnum "postgres.public.payment_state" PaymentState + + +newtype Status = Status PaymentState + deriving stock (Eq, Show) + deriving (Value) via Domain "payment_status" PaymentState + + +newtype Label = Label Text + deriving stock (Eq, Show) + deriving newtype (Value) + + +newtype Cents = Cents Int64 + deriving stock (Eq, Show) + deriving (Value) via Domain "cents" Int64 + + +-- | Run a statement on the test database. +runStatement :: Text -> params -> Statement params result -> IO result +runStatement conn params statement = do + Right c <- Connection.acquire Pqi.Ffi.adapter (Settings.connectionString conn) + result <- Connection.use c (Session.statement params statement) + Connection.release c + either (\e -> expectationFailure (show e) >> error "unreachable") pure result + + +runtimeSpec :: TestDef '[Text] () +runtimeSpec = do + itWithOuter "reads a varchar column as Text" \conn -> + runStatement conn (1 :: Int32) [Inferred.singletonStatement|select label from tag where id = $1|] + `shouldReturn` ("red" :: Text) + + itWithOuter "reads an int4 column as Int64, and sends an Int64 parameter for it" \conn -> + runStatement conn (1 :: Int64) [Inferred.singletonStatement|select id from tag where id = $1|] + `shouldReturn` (1 :: Int64) + + itWithOuter "reads a tuple, with a Maybe for a NULL" \conn -> + runStatement conn (1 :: Int32) [Inferred.maybeStatement|select label, null from tag where id = $1|] + `shouldReturn` Just ("red" :: Text, Nothing :: Maybe Text) + + itWithOuter "sends a literal that looks like an annotation unchanged" \conn -> + runStatement conn () [Inferred.singletonStatement|select ' :: hasql_check_slot_c1'|] + `shouldReturn` (" :: hasql_check_slot_c1" :: Text) + + -- Ordered by the column the alias "id" names, label, rather than v.id. + itWithOuter "keeps the order of SELECT DISTINCT by an alias" \conn -> + runStatement conn () [Inferred.singletonStatement|select distinct id as key, label as id from (values (2, 'a'), (1, 'b')) v (id, label) order by id limit 1|] + `shouldReturn` (2 :: Int64, "a" :: Text) + + itWithOuter "runs SELECT DISTINCT ON, ordered by an output name, with a cast column" \conn -> + runStatement conn () [Inferred.vectorStatement|select distinct on (t.id) t.id from tag t where t.id = 1 order by id|] + `shouldReturn` Vector.fromList [1 :: Int64] + + itWithOuter "runs GROUP BY a primary key, with a cast column" \conn -> + runStatement conn () [Inferred.vectorStatement|select id, label from tag where id = 1 group by 1|] + `shouldReturn` Vector.fromList [(1 :: Int64, "red" :: Text)] + + itWithOuter "runs a statement that does not use all its parameters" \conn -> + runStatement conn (1 :: Int64, 2 :: Int64) [Inferred.singletonStatement|select $2|] + `shouldReturn` (2 :: Int64) + + itWithOuter "reads a newtype as the type it wraps" \conn -> + runStatement conn (1 :: Int32) [Inferred.singletonStatement|select label from tag where id = $1|] + `shouldReturn` Label "red" + + itWithOuter "sends and reads a newtype as the domain it derives" \conn -> + runStatement conn (Cents 5) [Inferred.singletonStatement|select $1|] + `shouldReturn` Cents 5 + + itWithOuter "reads an array as a Vector" \conn -> + runStatement conn (1 :: Int32) [Inferred.singletonStatement|select labels from tagged where id = $1|] + `shouldReturn` Vector.fromList ["a", "b" :: Text] + + itWithOuter "reads an int4[] with NULLs as a Vector of Maybe Int64" \conn -> + runStatement conn (1 :: Int32) [Inferred.singletonStatement|select scores from tagged where id = $1|] + `shouldReturn` Vector.fromList [Just 1, Nothing, Just (3 :: Int64)] + + itWithOuter "subscripts an array parameter" \conn -> + runStatement conn [10, 20 :: Int64] [Inferred.singletonStatement|select $1[2]|] + `shouldReturn` (20 :: Int64) + + itWithOuter "sends a list as an array" \conn -> + runStatement conn [1, 2 :: Int64] [Inferred.vectorStatement|select id from tagged where id = any($1)|] + `shouldReturn` Vector.fromList [1 :: Int64] + + itWithOuter "reads an enum as a Haskell enumeration" \conn -> + runStatement conn (1 :: Int32) [Inferred.singletonStatement|select state from payment where id = $1|] + `shouldReturn` PAID + + itWithOuter "reads an enum named with its schema and in quotes" \conn -> + runStatement conn (1 :: Int32) [Inferred.singletonStatement|select state from payment where id = $1|] + `shouldReturn` Qualified PAID + + itWithOuter "reads an enum named with the database too" \conn -> + runStatement conn (1 :: Int32) [Inferred.singletonStatement|select state from payment where id = $1|] + `shouldReturn` InDatabase PAID + + itWithOuter "reads a domain over an enum" \conn -> + runStatement conn (1 :: Int32) [Inferred.singletonStatement|select status from payment_log where id = $1|] + `shouldReturn` Status REFUNDED + + itWithOuter "sends a Haskell enumeration as an enum" \conn -> + runStatement conn PENDING [Inferred.singletonStatement|select count(*) from payment where state = $1|] + `shouldReturn` (0 :: Int64) + + itWithOuter "runs a statement without rows" \conn -> + runStatement conn ("blue" :: Text, 2 :: Int64) [Inferred.resultlessStatement|insert into tag (label, id) values ($1, $2)|] + `shouldReturn` () + + +-- | A quote as hasql-check-hie writes it: its SQL, and the qualified name and +-- Postgres type of each parameter and result column. +inferredQuote :: Text -> Text -> [Column] -> Maybe [Column] -> Text +inferredQuote quoter sql params row = + "{\"file\":\"src/Fixture.hs\",\"line\":3,\"column\":7,\"quoter\":\"" + <> quoter + <> "\",\"sql\":\"" + <> sql + <> "\",\"params\":" + <> columns params + <> ",\"row\":" + <> maybe "null" columns row + <> "}" + where + columns cs = "[" <> Text.intercalate "," (map column cs) <> "]" + column c = + "{\"type\":\"" + <> c.haskell + <> "\",\"postgres\":\"" + <> c.postgres + <> "\",\"labels\":[" + <> Text.intercalate "," ["\"" <> l <> "\"" | l <- c.labels] + <> "],\"nullable\":" + <> (if c.nullable then "true" else "false") + <> "}" + + +data Column = Column {haskell :: Text, postgres :: Text, nullable :: Bool, labels :: [Text]} + + +-- | The same column, as a 'Maybe'. +optional :: Column -> Column +optional c = c{nullable = True} + + +-- | Run with --inferred on the given quotes and flags. +runInferred :: Text -> [String] -> [Text] -> IO (ExitCode, String) +runInferred conn args quotes' = + withSystemTempDirectory "hasql-check-inferred" \dir -> do + let file = dir "quotes.jsonl" + ByteString.Lazy.writeFile file (ByteString.Lazy.fromStrict (Text.Encoding.encodeUtf8 (Text.unlines quotes'))) + (code, out, err) <- readCreateProcessWithExitCode (proc "hasql-check" (["--database", Text.unpack conn, "--inferred", file] <> args)) "" + pure (code, out <> err) + + +int32, int64, text :: Column +int32 = Column "GHC.Internal.Int.Int32" "int4" False [] +int64 = Column "GHC.Internal.Int.Int64" "int8" False [] +text = Column "Data.Text.Internal.Text" "text" False [] + + +inferredSpec :: TestDef '[Text] () +inferredSpec = do + itWithOuter "accepts a statement whose Haskell types fit" \conn -> + runInferred conn [] [inferredQuote "singletonStatement" "select label, id from tag where id = $1" [int64] (Just [text, int64])] + `shouldReturn` (ExitSuccess, "") + + itWithOuter "rejects one that does not prepare, and says where it is" \conn -> do + (code, out) <- runInferred conn [] [inferredQuote "singletonStatement" "select nope from tag" [] (Just [text])] + code `shouldBe` ExitFailure 1 + out `shouldSatisfy` ("src/Fixture.hs:3:7" `isInfixOf`) + out `shouldSatisfy` ("column \"nope\" does not exist" `isInfixOf`) + + itWithOuter "rejects a Haskell type with too few columns" \conn -> do + (code, out) <- runInferred conn [] [inferredQuote "singletonStatement" "select label, id from tag" [] (Just [text])] + code `shouldBe` ExitFailure 1 + out `shouldSatisfy` ("the statement returns 2 columns, but the Haskell type reads 1" `isInfixOf`) + + itWithOuter "accepts the columns behind a *, cast to the types read" \conn -> + runInferred conn [] [inferredQuote "singletonStatement" "select * from tag" [] (Just [int64, text])] + `shouldReturn` (ExitSuccess, "") + + itWithOuter "accepts a qualified * whose columns have the types read" \conn -> + runInferred conn [] [inferredQuote "vectorStatement" "select a.* from account a" [] (Just [int32, text, optional text])] + `shouldReturn` (ExitSuccess, "") + + itWithOuter "accepts SELECT DISTINCT ordered by a column it annotates" \conn -> + runInferred conn [] [inferredQuote "vectorStatement" "select distinct id from tag order by id" [] (Just [int64])] + `shouldReturn` (ExitSuccess, "") + + itWithOuter "accepts SELECT DISTINCT ordered by a qualified column and an expression" \conn -> + runInferred conn [] [inferredQuote "vectorStatement" "select distinct t.id, t.id + 1 from tag t order by t.id, t.id + 1" [] (Just [int64, int64])] + `shouldReturn` (ExitSuccess, "") + + itWithOuter "accepts statements that a cast in place would break" \conn -> + runInferred + conn + [] + [ inferredQuote "vectorStatement" "select distinct on (t.id) t.id from tag t order by id" [] (Just [int64]) + , inferredQuote "vectorStatement" "select id, label from tag group by 1" [] (Just [int64, text]) + ] + `shouldReturn` (ExitSuccess, "") + + itWithOuter "accepts a parenthesised statement with a data-modifying WITH" \conn -> + runInferred conn [] [inferredQuote "vectorStatement" "(with x as (update tag set label = label returning id) select id from x)" [] (Just [int64])] + `shouldReturn` (ExitSuccess, "") + + itWithOuter "warns about a narrowed column of SELECT DISTINCT ON, which a cast in place would break" \conn -> do + (_, out) <- runInferred conn ["--types"] [inferredQuote "vectorStatement" "select distinct on (t.id) t.id from ledger t order by id" [] (Just [int32])] + out `shouldSatisfy` ("column 1 (id) is read as integer, but is a bigint: it may overflow" `isInfixOf`) + + itWithOuter "warns about a nullable column behind a *" \conn -> do + (_, out) <- runInferred conn ["--nullability"] [inferredQuote "vectorStatement" "select * from account" [] (Just [int32, text, text])] + out `shouldSatisfy` ("column 3 (nickname) is not a Maybe in Haskell, but public.account.nickname is nullable" `isInfixOf`) + + itWithOuter "still checks a source quote at the same place in another package" \conn -> + withSystemTempDirectory "hasql-check-other" \dir -> do + let source = dir "other" "src" "Fixture.hs" + quotesFile = dir "quotes.jsonl" + createDirectoryIfMissing True (dir "other" "src") + writeFile source "module Fixture where\n\ng = [singletonStatement|select nope :: text from account|]\n" + ByteString.Lazy.writeFile quotesFile (ByteString.Lazy.fromStrict (Text.Encoding.encodeUtf8 (inferredQuote "singletonStatement" "select 1" [] (Just [int32])))) + (code, out, err) <- readCreateProcessWithExitCode (proc "hasql-check" ["--database", Text.unpack conn, source, "--inferred", quotesFile]) "" + code `shouldBe` ExitFailure 1 + (out <> err) `shouldSatisfy` ("column \"nope\" does not exist" `isInfixOf`) + + itWithOuter "accepts a subscripted parameter, which it uses" \conn -> + runInferred conn [] [inferredQuote "singletonStatement" "select $1['a']" [Column "Data.Aeson.Types.Internal.Value" "jsonb" False []] (Just [Column "Data.Aeson.Types.Internal.Value" "jsonb" True []])] + `shouldReturn` (ExitSuccess, "") + + -- It runs, but whatever it was meant to do with $1, it does not. + itWithOuter "rejects a statement that does not use a parameter the Haskell type sends" \conn -> do + (code, out) <- runInferred conn [] [inferredQuote "singletonStatement" "select $2" [int64, int64] (Just [int64])] + code `shouldBe` ExitFailure 1 + out `shouldSatisfy` ("the Haskell type sends parameter $1, which the statement does not use" `isInfixOf`) + out `shouldNotSatisfy` ("could not determine" `isInfixOf`) + + itWithOuter "checks a quote in a source file it also has from --inferred once, as inferred" \conn -> + withSystemTempDirectory "hasql-check-both" \dir -> do + let source = dir "src" "Fixture.hs" + quotesFile = dir "quotes.jsonl" + createDirectoryIfMissing True (dir "src") + -- Line 3, with the quote at column 7, as the inferred quote says. + writeFile source "module Fixture where\n\ng = [singletonStatement|select $1 + $2|]\n" + ByteString.Lazy.writeFile quotesFile (ByteString.Lazy.fromStrict (Text.Encoding.encodeUtf8 (inferredQuote "singletonStatement" "select $1 + $2" [int64, int64] (Just [int64])))) + (code, out, err) <- readCreateProcessWithExitCode (proc "hasql-check" ["--database", Text.unpack conn, source, "--inferred", quotesFile]) "" + (code, out <> err) `shouldBe` (ExitSuccess, "") + + itWithOuter "rejects a Haskell type that sends more parameters than the statement uses" \conn -> do + (code, out) <- runInferred conn [] [inferredQuote "singletonStatement" "select 1" [int64] (Just [int32])] + code `shouldBe` ExitFailure 1 + out `shouldSatisfy` ("the Haskell type sends parameter $1, which the statement does not use" `isInfixOf`) + + itWithOuter "rejects a Haskell type that sends fewer, without rows too" \conn -> do + (code, out) <- runInferred conn [] [inferredQuote "resultlessStatement" "delete from tag where id = $1" [] Nothing] + code `shouldBe` ExitFailure 1 + out `shouldSatisfy` ("the statement uses $1, but the Haskell type sends 0 parameters" `isInfixOf`) + + itWithOuter "accepts a column of a domain, read as a newtype deriving it" \conn -> + runInferred conn [] [inferredQuote "singletonStatement" "select price from ledger" [] (Just [Column "Shop.Cents" "cents" True []])] + `shouldReturn` (ExitSuccess, "") + + itWithOuter "rejects a column Postgres converts to the type read only when told to" \conn -> do + (code, out) <- runInferred conn [] [inferredQuote "vectorStatement" "select name from account" [] (Just [Column "Shop.Nickname" "int8" False []])] + code `shouldBe` ExitFailure 1 + out `shouldSatisfy` ("column 1 (name) is text, but is read as Shop.Nickname (bigint), which Postgres converts it to only when told to" `isInfixOf`) + + itWithOuter "accepts an array whose elements Postgres converts on its own" \conn -> + runInferred conn [] [inferredQuote "singletonStatement" "select scores from tagged" [] (Just [Column "Data.Vector.Vector (Maybe Int64)" "int8[]" True []])] + `shouldReturn` (ExitSuccess, "") + + itWithOuter "rejects an array whose elements Postgres converts only when told to" \conn -> do + (code, out) <- runInferred conn [] [inferredQuote "singletonStatement" "select labels from tagged" [] (Just [Column "Data.Vector.Vector Int64" "int8[]" False []])] + code `shouldBe` ExitFailure 1 + out `shouldSatisfy` ("column 1 (labels) is text[], but is read as Data.Vector.Vector Int64 (bigint[]), which Postgres converts it to only when told to" `isInfixOf`) + + itWithOuter "warns about an array read as one of narrower elements, whose cast is accepted" \conn -> do + (code, out) <- runInferred conn ["--types"] [inferredQuote "vectorStatement" "select amounts from totals" [] (Just [Column "Data.Vector.Vector Int32" "int4[]" False []])] + code `shouldBe` ExitSuccess + out `shouldSatisfy` ("column 1 (amounts) is read as integer[], but is a bigint[]: it may overflow" `isInfixOf`) + + itWithOuter "warns about an array parameter sent to a column of narrower elements" \conn -> do + (_, out) <- runInferred conn ["--types"] [inferredQuote "resultlessStatement" "update tagged set scores = $1" [Column "Data.Vector.Vector Int64" "int8[]" False []] Nothing] + out `shouldSatisfy` ("parameter $1 is sent as bigint[], but is assigned to an integer[] column: it may overflow" `isInfixOf`) + + itWithOuter "warns about a nullable array read without a Maybe" \conn -> do + (_, out) <- runInferred conn ["--nullability"] [inferredQuote "vectorStatement" "select scores from tagged" [] (Just [Column "Data.Vector.Vector (Maybe Int64)" "int8[]" False []])] + out `shouldSatisfy` ("column 1 (scores) is not a Maybe in Haskell, but public.tagged.scores is nullable" `isInfixOf`) + itWithOuter "accepts NULL and string literals, typed by the cast" \conn -> + runInferred + conn + [] + [ inferredQuote "singletonStatement" "select NULL" [] (Just [Column "GHC.Internal.Int.Int64" "int8" True []]) + , inferredQuote "singletonStatement" "select '2026-10-29'" [] (Just [Column "Data.Time.Calendar.Days.Day" "date" False []]) + ] + `shouldReturn` (ExitSuccess, "") + + itWithOuter "rejects a string literal that is not of the type read" \conn -> do + (code, out) <- runInferred conn [] [inferredQuote "singletonStatement" "select 'abc'" [] (Just [Column "Data.UUID.Types.Internal.UUID" "uuid" False []])] + code `shouldBe` ExitFailure 1 + out `shouldSatisfy` ("column 1 (?column?) is 'abc', which cannot be read as Data.UUID.Types.Internal.UUID" `isInfixOf`) + + itWithOuter "accepts any column read as text, which Postgres converts to on assignment" \conn -> + runInferred conn [] [inferredQuote "vectorStatement" "select id from account" [] (Just [text])] + `shouldReturn` (ExitSuccess, "") + + itWithOuter "accepts a domain over a domain, read as the type at the bottom" \conn -> + runInferred conn [] [inferredQuote "vectorStatement" "select balance from wallet" [] (Just [Column "Shop.Positive" "positive_cents" False []])] + `shouldReturn` (ExitSuccess, "") + + itWithOuter "accepts a domain column behind a *" \conn -> + runInferred conn [] [inferredQuote "vectorStatement" "select x.* from (select price from ledger) x" [] (Just [Column "Shop.Cents" "cents" True []])] + `shouldReturn` (ExitSuccess, "") + + itWithOuter "rejects a Postgres type that does not exist, behind a * too" \conn -> do + (code, out) <- runInferred conn [] [inferredQuote "singletonStatement" "select x.* from (select 'abc'::text) x" [] (Just [Column "Shop.Missing" "missing_domain" False []])] + code `shouldBe` ExitFailure 1 + out `shouldSatisfy` ("no such Postgres type: missing_domain" `isInfixOf`) + + itWithOuter "rejects a UNION whose branches do not agree, which fails as sent too" \conn -> do + (code, out) <- runInferred conn [] [inferredQuote "singletonStatement" "select name from account union all select 1" [] (Just [int64])] + code `shouldBe` ExitFailure 1 + out `shouldSatisfy` ("UNION types text and integer cannot be matched" `isInfixOf`) + + itWithOuter "accepts an enum read with all its labels" \conn -> + runInferred conn [] [inferredQuote "singletonStatement" "select state from payment" [] (Just [Column "Shop.State" "payment_state" False ["PENDING", "PAID", "REFUNDED"]])] + `shouldReturn` (ExitSuccess, "") + + itWithOuter "rejects an enum read without a label the database has" \conn -> do + (code, out) <- runInferred conn [] [inferredQuote "singletonStatement" "select state from payment" [] (Just [Column "Shop.State" "payment_state" False ["PENDING", "PAID"]])] + code `shouldBe` ExitFailure 1 + out `shouldSatisfy` ("column 1 (state) is read as Shop.State, which cannot read labels payment_state has: REFUNDED" `isInfixOf`) + + itWithOuter "accepts an enum sent with fewer labels than the database has" \conn -> + runInferred conn [] [inferredQuote "resultlessStatement" "update payment set state = $1" [Column "Shop.Transition" "payment_state" False ["PAID"]] Nothing] + `shouldReturn` (ExitSuccess, "") + + itWithOuter "accepts a domain over an enum, read with all its labels" \conn -> + runInferred conn [] [inferredQuote "singletonStatement" "select status from payment_log" [] (Just [Column "Shop.Status" "payment_status" False ["PENDING", "PAID", "REFUNDED"]])] + `shouldReturn` (ExitSuccess, "") + + itWithOuter "rejects a domain over an enum read without a label the enum has" \conn -> do + (code, out) <- runInferred conn [] [inferredQuote "singletonStatement" "select status from payment_log" [] (Just [Column "Shop.Status" "payment_status" False ["PENDING", "PAID"]])] + code `shouldBe` ExitFailure 1 + out `shouldSatisfy` ("which cannot read labels payment_status has: REFUNDED" `isInfixOf`) + + itWithOuter "rejects an enum sent with a label the database does not have" \conn -> do + (code, out) <- runInferred conn [] [inferredQuote "resultlessStatement" "update payment set state = $1" [Column "Shop.Transition" "payment_state" False ["PAID", "CANCELLED"]] Nothing] + code `shouldBe` ExitFailure 1 + out `shouldSatisfy` ("parameter $1 is sent as Shop.Transition, with labels payment_state does not have: CANCELLED" `isInfixOf`) + + itWithOuter "rejects a Postgres type the database does not have" \conn -> do + (code, out) <- runInferred conn [] [inferredQuote "singletonStatement" "select label from tag" [] (Just [Column "Shop.Label" "nosuchtype" False []])] + code `shouldBe` ExitFailure 1 + out `shouldSatisfy` ("no such Postgres type: nosuchtype" `isInfixOf`) + + itWithOuter "warns about a nullable column read without a Maybe" \conn -> do + (_, out) <- runInferred conn ["--nullability"] [inferredQuote "vectorStatement" "select nickname from account" [] (Just [text])] + out `shouldSatisfy` ("column 1 (nickname) is not a Maybe in Haskell, but public.account.nickname is nullable" `isInfixOf`) + + itWithOuter "accepts a nullable column read as a Maybe" \conn -> + runInferred conn ["--nullability"] [inferredQuote "vectorStatement" "select nickname from account" [] (Just [optional text])] + `shouldReturn` (ExitSuccess, "") + + itWithOuter "warns about a column read as a narrower type" \conn -> do + (_, out) <- runInferred conn ["--types"] [inferredQuote "vectorStatement" "select amount from ledger" [] (Just [int32])] + out `shouldSatisfy` ("column 1 (amount) is read as integer, but is a bigint: it may overflow" `isInfixOf`) + + itWithOuter "fingerprints an inferred statement by its result types too, for baselines" \conn -> + withSystemTempDirectory "hasql-check-baseline" \dir -> do + let baseline = dir "baseline" + readAs t = inferredQuote "vectorStatement" "select amount from ledger" [] (Just [t]) + int16 = Column "GHC.Internal.Int.Int16" "int2" False [] + _ <- runInferred conn ["--types", "--write-baseline", baseline] [readAs int32] + -- The same statement stays suppressed; read as a narrower type, it + -- is another statement, and is not. + runInferred conn ["--types", "--baseline", baseline, "--fail-on-warnings"] [readAs int32] + `shouldReturn` (ExitSuccess, "") + (code, out) <- runInferred conn ["--types", "--baseline", baseline, "--fail-on-warnings"] [readAs int16] + code `shouldBe` ExitFailure 1 + out `shouldSatisfy` ("column 1 (amount) is read as smallint, but is a bigint: it may overflow" `isInfixOf`) + + itWithOuter "warns about a parameter assigned to a narrower column" \conn -> do + (_, out) <- runInferred conn ["--types"] [inferredQuote "resultlessStatement" "update ledger set small = $1" [int64] Nothing] + out `shouldSatisfy` ("parameter $1 is sent as bigint, but is assigned to a smallint column: it may overflow" `isInfixOf`)